Блог

Я новичок в VBA, и у меня есть проблема в вышеупомянутой теме, которую я хочу скопировать определенный диапазон из многих листов в рабочей книге на один лист в другой рабочей книге Я искал в сети и, наконец, дошел до кода, который запускается, но он дает мне только данные последнего листа, а не все листы

У меня есть рабочая книга (WB1) — Текущая рабочая книга

У меня есть другая рабочая книга (WB2) — Копировать из книги

У меня есть WS1 в текущей книге

У меня есть WS2 в копии из книги

Имена рабочих листов в WB2 — это такие числа, как 1,2 и так далее

Я использовал следующий код

     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)
  

Код дает мне данные только на последнем листе?? в этом случае 2

Ценю вашу поддержку.

Спасибо, с уважением

Я тоже новичок, и я печатаю на своем планшете, поэтому не могу протестировать ваш код, но похоже, что вы всегда вставляете в один и тот же диапазон, перезаписывая предыдущие вставки в своем цикле. Ваш целевой диапазон должен быть динамическим для вставки в следующий пустой диапазон, чтобы избежать перезаписи.

Обновить:

Мне пришлось вернуться к этому, и, как я и предполагал, вы копировали предыдущие вставки при каждом запуске вашего цикла. Мой код, вероятно, немного грубый, но, как я уже сказал, я все еще изучаю основы самостоятельно. Обновите «путь» в книгах.откройте строку и попробуйте. Это должно сработать для вас.

 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" amp; NextRow)
    End If
    Next ws2
    Application.DisplayAlerts = True
    wb2.Close True
End Sub
  

Копировать диапазон из нескольких листов

 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:Test64010480.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