Search code examples
excelvba

How to insert value from another worksheet below my last value cell from my test summary sheet


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


Solution

  • 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