Trying to copy specific range from many sheets in workbook to one sheet in another workbook vba excel?

Question

I'm a beginner in VBA and I have a problem in above subject which I want to copy specific range from many sheets in workbook to one sheet in another workbook I searched the net and finally I reached to a code which runs but it gives me the last sheet data only not all sheets

I have a Workbook (WB1) - Current Workbook

I have another Work Book (WB2) - Copy from Workbook

I have WS1 in the Current Workbook

I have WS2 in the Copy from Workbook

The Work sheets names in WB2 are Numbers like 1,2 and so on

I used the following code

    Sub CollectData()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Application.DisplayAlerts = False
    Set wb1 = ThisWorkbook
    Set wb2 = Workbooks.Open("Path")
    Set ws1 = wb1.Sheets("Jan")
    For Each ws2 In wb2.Sheets
    If Len(ws2.Name) > 0 Then
    ws2.Range("A2:G50").Copy Destination:=ws1.Range("A2:G50")
    End If
    Next ws2
    Application.DisplayAlerts = True
    wb2.Close (savechanges = True)

The Code gives me data in the last sheet only ?? in this case 2

Appreciate your support.

Thanks, Regards

Answer 1

I'm a beginner too and I'm typing on my tablet so I can't test your code but it looks like you are always pasting to the same range thus overwriting the previous pastes in your loop. Your destination range needs to be dynamic to paste in the next empty range so as to avoid overwriting.

Update:

I've had to time come back to this and as I had assumed you were copying over previous pastes with each run of your loop. My code is probably a bit crude but as I said I am still learning the basics myself. Update the "path" in the workbooks.open line and give this a go. It should work for you.

Sub CollectData()
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    
    Dim NextRow As Long
    
    Set wb1 = ThisWorkbook
    Set ws1 = wb1.Sheets("Jan")
  
    Application.DisplayAlerts = False
    
    Set wb2 = Workbooks.Open("Path")
   
    For Each ws2 In wb2.Sheets
    If Len(ws2.Name) > 0 Then
    NextRow = ws1.Cells(Rows.Count, 1).End(xlUp).Row + 1
    ws2.Range("A2:G50").Copy ws1.Range("A" & NextRow)
    End If
    Next ws2
    Application.DisplayAlerts = True
    wb2.Close True
End Sub

Answer 2

Copy Range From Multiple Worksheets

Option Explicit

Sub CollectData()

    ' Paste
    Dim wb1 As Workbook
    Set wb1 = ThisWorkbook
    Dim ws1 As Worksheet
    Set ws1 = wb1.Sheets("Jan")
    Dim rng1 As Range ' Paste Range (First Cell Only)
    
    ' Copy
    Dim wb2 As Workbook
    Set wb2 = Workbooks.Open("F:\Test\64010480.xlsm")
    Dim ws2 As Worksheet
    Dim rng2 As Range ' Copy Range
    
    ' Loop through worksheets in Copy Workbook.
    For Each ws2 In wb2.Worksheets
        ' Check if the current worksheet's name contains only one character
        ' (it cannot contain 0 characters).
        If Len(ws2.Name) < 2 Then
            ' Define Copy Range.
            Set rng2 = ws2.Range("A2:G50")
            ' Define first cell range of Paste Range.
            Set rng1 = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Offset(1)
            ' Either (if you only need values)...
            ' Write values from Copy Range to Paste Range.
            rng1.Resize(rng2.Rows.Count, rng2.Columns.Count).Value = rng2.Value
            ' ...or (if you also need formulas and formats).
            ' Copy data from Copy Range to Paste Range.
            'rng2.Copy Destination:=rng1
        End If
    Next ws2
    
    ' Close Copy Workbook.
    wb2.Close SaveChanges:=False ' No need to save it, we were just reading.
     
    ' Maybe you want to save the Paste Workbook.
    'wb1.Save
     
End Sub