excelvbacopy-paste

Searching for a more efficient way to copy a variable range from multiple sheets to a single sheet? Rows vary, Columns constant


This data can include formulas, conditional formatting, etc. which if possible go away on summary sheet by pasting only the values.

Thanks for any assistance.

I am new to VBA and could not find anything to help with this combination of questions.

Sub RefreshData()
Sheets("DATA").Cells.Clear

Application.Calculation = xlCalculationManual

' SITE1

   Dim LastRow As Long

   'Find last used row of sheet SITE1
   With Worksheets("SITE1")
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With

   'Find first row to paste values on sheet DATA
   With Worksheets("DATA")
      j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   End With
   
   'Paste each row of SITE1 into DATA
   For i = 4 To LastRow
       With Worksheets("SITE1")
            .Rows(i).Copy Destination:=Worksheets("DATA").Range("A" & j)
            j = j + 1
       End With
   Next i
   
'SITE2

   'Find last used row of sheet SITE2
   With Worksheets("SITE2")
      LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   End With

   'Find first row to paste values on sheet DATA
   With Worksheets("DATA")
      j = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
   End With
   
   'Paste each row of SITE2 into DATA
   For i = 5 To LastRow
       With Worksheets("SITE2")
            .Rows(i).Copy Destination:=Worksheets("DATA").Range("A" & j)
            j = j + 1
       End With
   Next i

' Show all rows and columns in DATA
Sheets("DATA").Cells.EntireRow.Hidden = False
Sheets("DATA").Cells.EntireColumn.Hidden = False

Call setCategories
Call setAge

ActiveWorkbook.RefreshAll

MsgBox "All Data Refreshed.", vbOKOnly
   
Application.Calculation = xlCalculationAutomatic
   
End Sub

Solution

  • Untested. but something like this should work (assuming everything is in the same workbook: adjust as needed)

    Sub RefreshData()
        
        Dim wsData As Worksheet, wb As Workbook, ws As Worksheet, i As Long
        Dim data, lr As Long, cDest As Range
        
        Set wb = ThisWorkbook  'adjust as needed if macro is in a different workbook
        Set wsData = wb.Worksheets("Data")
        
        wsData.Cells.Clear
        Set cDest = wsData.Range("A5") 'first data destination
        
        Application.Calculation = xlCalculationManual
        
        For i = 1 To 17
            Set ws = wb.Worksheets("SITE" & i)
            If i = 1 Then ws.Range("A4:AT4").Copy wsData.Range("A4")
            lr = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
            If lr > 4 Then 'any data to copy?
                'read range values into a 2D 1-based array
                data = ws.Range("A5", ws.Cells(lr, "AT")).Value 'read to array
                cDest.Resize(UBound(data, 1), UBound(data, 2)).Value = data 'write values only
                Set cDest = cDest.Offset(UBound(data, 1)) 'next destination start
            End If
        Next i
        
        '...
        'etc etc
        '...
    End Sub