For loop to save time when copy data in columns range from another file worksheet

[chicharito14]

Hi VBA experts,

Could you help me to write a for loop of this code. The purpose of this vba code is search for sheets that matchs SheetName column in SourceFile, copy data until the last rows of entry in Columns Range of Source File to Destination File.

I can do it without a loop as the code below.

Sub CopyPaste_ColumnsRange()
    
    Dim SourceFile As String, DestinationFile As String
    
    Dim SheetName1 As String, SheetName2 As String, SheetName3 As String
    Dim ColumnRange1 As String, ColumnRange2 As String, ColumnRange3 As String
    Dim LastRow1 As Long, LastRow2 As Long, LastRow3 As Long
    Dim WS1S As Worksheet, WS2S As Worksheet, WS3S As Worksheet, WS1D As Worksheet, WS2D As Worksheet, WS3D As Worksheet
    
    SourceFile = ActiveSheet.Range("C2")
    DestinationFile = ActiveSheet.Range("D2")
    
    SheetName1S = ActiveSheet.Range("A2")
    SheetName1D = Left(SheetName1S, 6)
    ColumnRange1 = ActiveSheet.Range("B2")
    Set WS1S = Workbooks(SourceFile).Sheets(SheetName1S)
    Set WS1D = Workbooks(DestinationFile).Sheets(SheetName1D)
    LastRow1 = WS1S.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
    Intersect(WS1S.Rows("1:" & LastRow1), WS1S.Range(ColumnRange1)).Copy WS1D.Range("A1")
    
    SheetName2S = ActiveSheet.Range("A3")
    SheetName2D = Left(SheetName2S, 6)
    ColumnRange2 = ActiveSheet.Range("B3")
    Set WS2S = Workbooks(SourceFile).Sheets(SheetName2S)
    Set WS2D = Workbooks(DestinationFile).Sheets(SheetName2D)
    LastRow2 = WS2S.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
    Intersect(WS2S.Rows("1:" & LastRow2), WS2S.Range(ColumnRange2)).Copy WS2D.Range("A1")
    
    SheetName3S = ActiveSheet.Range("A4")
    SheetName3D = Left(SheetName3S, 6)
    ColumnRange3 = ActiveSheet.Range("B4")
    Set WS3S = Workbooks(SourceFile).Sheets(SheetName3S)
    Set WS3D = Workbooks(DestinationFile).Sheets(SheetName3D)
    LastRow3 = WS3S.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
    Intersect(WS3S.Rows("1:" & LastRow3), WS3S.Range(ColumnRange3)).Copy WS3D.Range("A1")
    
End Sub

 

[Zot]

I hope I'm not missing anything, but I think you can understand the flow and make correction if any

Sub CopyPaste_ColumnsRange()
  
    Dim SourceFile As String, DestinationFile As String
  
    Dim SheetNameS As String, SheetNameD As String
    Dim ColumnRangeS As String
    Dim LastRowS As Long, n As Long
    Dim wsS As Worksheet, wsD As Worksheet
  
    SourceFile = ActiveSheet.Range("C2")
    DestinationFile = ActiveSheet.Range("D2")
  
    For n = 2 To ActiveSheet.Range("A1").End(xlDown).Row
        SheetNameS = ActiveSheet.Range("A" & n)
        SheetNameD = Left(SheetNameS, 6)
        ColumnRangeS = ActiveSheet.Range("B" & n)
        Set wsS = Workbooks(SourceFile).Sheets(SheetNameS)
        Set wsD = Workbooks(DestinationFile).Sheets(SheetNameD)
        LastRowS = wsS.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
        Intersect(wsS.Rows("1:" & LastRowS), wsS.Range(ColumnRangeS)).Copy wsD.Range("A1")
    Next
  
End Sub

 

[chicharito14]

Thank you Zot for helping me understand the flow.

When I debug, it has problem at

For n = 2 To ActiveSheet.Range("A1").End(xlDown)

The error is Run-time 13, Type Mismatch. I guest we should change the ActiveSheet.Range("A1").End(xlDown) a little bit.

 

[Zot]

I edited it before time expired but I guess you get the previous one. I put .Row to give number but the previous one not having that, thus resulting a range I believe.

 

[chicharito14]

Hi Zot,

I double check again. It works perfectly. Thank you so much.