Forum Discussion

tridi94's avatar
tridi94
Copper Contributor
Feb 13, 2022
Solved

Excel Macro for copying data from multiple sheets using for loop

I need to copy over data from different sheets to one sheets in a single workbook .Need help how to do it using for loop. And the sheet count is different. the below mentioned first snippet is the m...
Macros and VBA
  • OliverScheurich's avatar
    OliverScheurich
    Feb 13, 2022

    tridi94 

    This code takes into account a different number of rows in the other worksheets. That might be even better suited to your task.

     

    Sub Macro1()

Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim u As Integer
Dim w As Integer
Dim no_of_rows As Integer


Range("C:E").Clear

z = 0
j = 3
For i = 2 To Worksheets.Count

With Worksheets(i)
no_of_rows = .Range("C" & .Rows.Count).End(xlUp).Row - 2
End With


Worksheets("main").Cells(j, 3).Value = Worksheets(i).Cells(1, 1).Value


For w = 3 To 4
For u = 1 To no_of_rows

Worksheets("main").Cells(u + 3 + z, w + 1).Value = Worksheets(i).Cells(u + 2, w).Value

Next u
Next w


j = j + 2 + no_of_rows
z = z + 2 + no_of_rows


Next i
End Sub

     

     

JMB17's avatar
JMB17
Bronze Contributor
Feb 13, 2022

tridi94 

 

You could also try this, assuming the data in your source worksheets are constants (hard coded and not formulas) and your main worksheet is called "MAIN" (otherwise, change the Set mainWksht = Worksheets("MAIN") to whatever yours is actually named).

 

Sub test()
     Dim wksht As Worksheet
     Dim rngToCopy As Range
     Dim mainWksht As Worksheet
     Dim rngToPaste As Range
     
     On Error GoTo ErrHandler
     
     Set mainWksht = Worksheets("MAIN")
     
     For Each wksht In ThisWorkbook.Worksheets
          If Not wksht Is mainWksht Then
               
               If Not IsEmpty(wksht.UsedRange) Then
                    With wksht
                         On Error Resume Next
                         Set rngToCopy = wksht.UsedRange.SpecialCells(xlCellTypeConstants)
                         On Error GoTo ErrHandler
                    End With
                    
                    If rngToCopy.Areas.Count = 2 Then
                         With mainWksht
                              If IsEmpty(.UsedRange) Then
                                   Set rngToPaste = .Range("C3")
                              Else
                                   Set rngToPaste = Intersect(.Range("C:C"), .UsedRange.SpecialCells(xlCellTypeLastCell).EntireRow)(3, 1)
                              End If
                         End With
                         
                         rngToCopy.Areas(1).Copy rngToPaste
                         rngToCopy.Areas(2).Copy rngToPaste(2, 2)
                    
                    Else
                         Err.Raise Number:=vbObjectError + 513, Description:="Unexpected number of range areas in source worksheet." & vbNewLine & vbNewLine & _
                              "Workhseet: " & wksht.Name & vbNewLine & "Area Count: " & rngToCopy.Areas.Count
                    End If
               End If
          End If
     Next wksht
     
     
ExitProc:
     Exit Sub
     
ErrHandler:
     MsgBox "Error " & Err.Number & ": " & Err.Description
     Resume ExitProc
     
End Sub

Resources