VBA Script for copying a range of cells from multiple worksheets into one worksheet?

[Rokhnal]

Hi all! Knocking out a huge project for work and I'm looking for anything to save time.

I have successfully imported ~100 workbooks into a single workbook as sheets, labeled "3" to "103". From each of those ~100 sheets I'd like to copy the data in cells A11:Ax, C11:Cx, E11:Ex, and I11:Ix (from row 11 to the last row of data in each of those columns) into the main worksheet labeled "Cleanup". Any suggestions?

Thank you!

 

[kevin9999]

Where do you want the data put in the "Cleanup" sheet? In matching columns (A to A, C to C etc.), or all to A - D; first empty row?

 

[Rokhnal]

Where do you want the data put in the "Cleanup" sheet? In matching columns (A to A, C to C etc.), or all to A - D; first empty row?

A-D, first empty row is perfect.

 

[kevin9999]

Please try the following on a copy of your workbook. I'm sure there'll be a quicker way of doing this using arrays, which I will work on later today. Assumes the sheet you referred to as "3" is indexed 3 in your workbook, with your Cleanup sheet in the first 2.

Option Explicit
Sub Consolidate_Sheets()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Cleanup")
    Dim n As Long, i As Long, j As Long, LRow As Long, a, b
    n = Worksheets.Count
    a = Array(1, 3, 5, 9)
    b = Array(1, 2, 3, 4)
    
    For i = 3 To n
        LRow = Worksheets(i).Cells.Find("*", , xlFormulas, , 1, 2).Row
        For j = LBound(a) To UBound(a)
            Worksheets(i).Range(Worksheets(i).Cells(11, a(j)), Worksheets(i).Cells(LRow, a(j))).Copy _
            ws1.Cells(Rows.Count, b(j)).End(xlUp).Offset(1)
        Next j
    Next i
    Application.ScreenUpdating = True
End Sub

 

[kevin9999]

The following should be considerably faster than post #4 - again, try it on a copy of your workbook.

Option Explicit
Sub Consolidate_With_Arrays()
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Cleanup")
    Dim n As Long, i As Long, j As Long, k As Long, m As Long, LRow As Long, x As Long, a, b
    n = Worksheets.Count
    
    'Load the input array
    Dim tmp, rng As Range
    ReDim a(1 To n - 2)
    j = 1
    For i = 3 To n
        LRow = Worksheets(i).Cells.Find("*", , xlFormulas, , 1, 2).Row
        Set rng = Worksheets(i).Range(Worksheets(i).Cells(11, 1), Worksheets(i).Cells(LRow, 9))
        ReDim tmp(1 To rng.Rows.Count, 1 To 4)
        For k = 1 To rng.Rows.Count
            tmp(k, 1) = rng.Cells(k, 1)
            tmp(k, 2) = rng.Cells(k, 3)
            tmp(k, 3) = rng.Cells(k, 5)
            tmp(k, 4) = rng.Cells(k, 9)
        Next k
        a(j) = tmp
        Set tmp = Nothing
        j = j + 1
        x = x + LRow - 10
    Next i
    
    'Load the output array
    Dim rw As Long, col As Long, r As Long, arr
    ReDim b(1 To x, 1 To 4)
    r = 1
    For i = 1 To n - 2
        arr = a(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                b(r, col) = arr(rw, col)
            Next col
            r = r + 1
        Next rw
    Next i
    
    'Put the output array to the Cleanup sheet
    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(b, 1), 4).Value = b
End Sub

 

[vcoolio]

Hello Rokhnal,

I think that Kevin's second code has hit the nail on the head but, FWIW, here's another option (untested though):-

Option Explicit

Sub Test()

     Dim wsCU As Worksheet, ws As Worksheet, ar As Variant
     Set wsCU = Sheets("Cleanup")
     
Application.ScreenUpdating = False

     wsCU.UsedRange.Offset(1).Clear
    
     For Each ws In Worksheets
            If ws.Name <> "Cleanup" And ws.Name <> "Your sheet name here" Then
                  With ws.Range("A11", ws.Range("I" & ws.Rows.Count).End(xlUp))
                         ar = Application.Index(.Value, Evaluate("Row(1:" & .Rows.Count & ")"), Array(1, 3, 5, 9))
                         wsCU.Range("A" & Rows.Count).End(3)(2).Resize(UBound(ar), 4) = ar
                  End With
            End If
     Next ws
     
     wsCU.Columns.AutoFit
    
Application.ScreenUpdating = True

End Sub

Obviously, there are two sheets that need to be excluded: the destination "Cleanup" sheet and "Sheet2"(seeing that your source sheets start at "Sheet3"). In the code above, just change "Your sheet name here" to the actual name of "Sheet2".

I hope that this may help.
Cheerio,
vcoolio.

 

[Rokhnal]

The following should be considerably faster than post #4 - again, try it on a copy of your workbook.

Option Explicit
Sub Consolidate_With_Arrays()
    Dim ws As Worksheet, ws1 As Worksheet
    Set ws1 = Worksheets("Cleanup")
    Dim n As Long, i As Long, j As Long, k As Long, m As Long, LRow As Long, x As Long, a, b
    n = Worksheets.Count
   
    'Load the input array
    Dim tmp, rng As Range
    ReDim a(1 To n - 2)
    j = 1
    For i = 3 To n
        LRow = Worksheets(i).Cells.Find("*", , xlFormulas, , 1, 2).Row
        Set rng = Worksheets(i).Range(Worksheets(i).Cells(11, 1), Worksheets(i).Cells(LRow, 9))
        ReDim tmp(1 To rng.Rows.Count, 1 To 4)
        For k = 1 To rng.Rows.Count
            tmp(k, 1) = rng.Cells(k, 1)
            tmp(k, 2) = rng.Cells(k, 3)
            tmp(k, 3) = rng.Cells(k, 5)
            tmp(k, 4) = rng.Cells(k, 9)
        Next k
        a(j) = tmp
        Set tmp = Nothing
        j = j + 1
        x = x + LRow - 10
    Next i
   
    'Load the output array
    Dim rw As Long, col As Long, r As Long, arr
    ReDim b(1 To x, 1 To 4)
    r = 1
    For i = 1 To n - 2
        arr = a(i)
        For rw = 1 To UBound(arr, 1)
            For col = 1 To UBound(arr, 2)
                b(r, col) = arr(rw, col)
            Next col
            r = r + 1
        Next rw
    Next i
   
    'Put the output array to the Cleanup sheet
    ws1.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(b, 1), 4).Value = b
End Sub

This is BRILLIANT! You've saved me so much time and manual effort, I really appreciate it; this worked exactly how I wanted it to.

 

[kevin9999]

Glad we could help & thanks for the feedback