Currently the macro allows me to copy data from my active sheet to test summary sheet but if I were to go to another sheet and run the macro, it will replace the data from my previous active sheet. So, I am trying to insert value from one sheet to my summary sheet and multiple other sheet to be added to my summary sheet. Right now I have tried setting the rng1 to the last valued cell so the data will be captured to the next row but it isn't working and the data copied will be the last value of my active sheet.
Sub test()
' test Macro
Dim Rng1 As Range, Rng2 As Range
Dim ws1 As Worksheet, ws2 As Worksheet, i As Long
Set ws1 = ThisWorkbook.Worksheets("Test Summary")
Set Rng1 = ws1.Range("E2")
Set ws2 = ThisWorkbook.ActiveSheet()
Set Rng2 = ws2.Range("F2")
i = 0
If Rng1.Value <> "" Then
With ws1.Range("E2")
Set lcell = .Resize(ws1.Rows.Count - .Row + 1) _
.Find("*", , xlValues, , , xlPrevious)
If lcell Is Nothing Then Exit Sub ' no data found
Set Rng1 = .Resize(lcell.Row - .Row + 1)
End With
End If
Do Until IsEmpty(Rng2.Offset(0, i))
If Rng2.Value <> "" Then
Rng1.Offset(0, 0).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([7], [1]).Address
Rng1.Offset(0, 1).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([9], [1]).Address
Rng1.Offset(0, 2).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([10], [1]).Address
Rng1.Offset(0, 4).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([12], [1]).Address
Rng1.Offset(0, 5).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([13], [1]).Address
Rng1.Offset(0, 6).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([14], [1]).Address
Rng1.Offset(0, 7).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([17], [1]).Address
Rng1.Offset(0, 8).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([18], [1]).Address
Rng1.Offset(0, 9).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([23], [1]).Address
Rng1.Offset(0, 10).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([24], [1]).Address
Rng1.Offset(0, 11).Formula = "='" & ws2.Name & "'!" & Rng2.Cells([25], [1]).Address
Set Rng2 = Rng2.Offset(0, i + 1)
End If
Set Rng1 = Rng1.Offset(1, 0) ' Move to next row to check
Loop
i = 0
' Clean up
Set Rng1 = Nothing
Set ws1 = Nothing
Set Rng2 = Nothing
Set ws2 = Nothing
End Sub
Please try.
Dim lcell
If Rng1.Value <> "" Then
With ws1
Set lcell = .Columns("E").Find("*", .Range("E1"), xlValues, xlWhole, , xlPrevious)
If lcell Is Nothing Then Exit Sub ' no data found
' Based on the logic of your code in OP, new data will overwrite the existing data on ws1
' Rng1 = .Range("E2:E" & lcell.Row)
' ** I think Rng1 should be the first blank cell
Set Rng1 = lcell.Offset(1)
End With
End If