копирование диапазона переменных ячеек с одного листа на другой

Question

У меня есть 12 листов с информацией внутри них. Некоторая информация, которую я хочу собрать из каждого листа на один лист.

Так,

я в первую очередь узнать, сколько строк я имею дело с, то я хочу, чтобы скопировать первые два столбца в другой лист (Результаты).

Теперь я могу получить первый столбец для копирования с каждого листа, но не может тренироваться, что я делаю неправильно, чтобы скопировать второй столбец.

Sub loopMe() 

Dim Jan As Worksheet, Feb As Worksheet, Mar As Worksheet, Apr As Worksheet, May As Worksheet, Jun As Worksheet 
Dim Jul As Worksheet, Aug As Worksheet, Sep As Worksheet, October As Worksheet, Nov As Worksheet, Dec As Worksheet 
Dim LstR As Long, rngJan As Range, c As Range, rngFeb As Range, rngMar As Range, rngApr As Range 
Dim rngMay As Range, rngJun As Range, rngJul As Range, rngAug As Range, rngSep As Range, rngOctober As Range 
Dim rngNov As Range, rngDec As Range 


Set Jan = Sheets("January")          'set the sheet to loop 
With Jan               'do something with the sheet 
    LstR = .Cells(.Rows.Count, "A").End(xlUp).Row    'find last row 
    Set rngJan = .Range("A2:B" & LstR)       'set range to loop 
End With 

Set Feb = Sheets("February")          'set the sheet to paste 
With Feb               'do something with the sheet 
    LstR = .Cells(.Rows.Count, "A").End(xlUp).Row    'find last row 
    Set rngFeb = .Range("A2:B" & LstR)       'set range to loop 
End With 

«выше следует установить диапазон данных в каждом листе (я надеюсь) » Тогда я запустить следующий

For Each y In rngJan 
    Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).Value = y.Value 
Next y 


For Each y In rngFeb 
    Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).Value = y.Value 
Next y 

Информацию мне нужно хранится в колонке А-& Б, чтобы они это то, что я пытаюсь скопировать.

Может ли кто-нибудь помочь?

Answer 1

Попробуйте это:

Сначала вы хотите только петли через колонку A.

Затем установите диапазоны двух столбцов, источник легко, как объявить диапазон у и y.offset. Цель использования изменить размер (, 2).

Sub loopMe() 

Dim Jan As Worksheet, Feb As Worksheet, Mar As Worksheet, Apr As Worksheet, May As Worksheet, Jun As Worksheet 
Dim Jul As Worksheet, Aug As Worksheet, Sep As Worksheet, October As Worksheet, Nov As Worksheet, Dec As Worksheet 
Dim LstR As Long, rngJan As Range, c As Range, rngFeb As Range, rngMar As Range, rngApr As Range 
Dim rngMay As Range, rngJun As Range, rngJul As Range, rngAug As Range, rngSep As Range, rngOctober As Range 
Dim rngNov As Range, rngDec As Range 


Set Jan = Sheets("January")          'set the sheet to loop 
With Jan               'do something with the sheet 
    LstR = .Cells(.Rows.Count, "A").End(xlUp).Row    'find last row 
    Set rngJan = .Range("A2:A" & LstR)       'set range to loop 
End With 

Set Feb = Sheets("February")          'set the sheet to paste 
With Feb               'do something with the sheet 
    LstR = .Cells(.Rows.Count, "A").End(xlUp).Row    'find last row 
    Set rngFeb = .Range("A2:A" & LstR)       'set range to loop 
End With 
' The above should set the range of data in each sheet (I hope) ' Then I run the following 

For Each y In rngJan 
    Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).resize(,2).Value = Range(y, y.Offset(, 1)).Value 
Next y 


For Each y In rngFeb 
    Worksheets("Results").Range("A65536").End(xlUp).Offset(1, 0).resize(,2).Value = Range(y, y.Offset(, 1)).Value 
Next y 
End Sub 

Answer 2

Попробуйте этот код для эффективного использования For...Next заявления, избегая чрезмерного использования объектных переменных. Он очищает предыдущие данные, прежде чем приступать к копированию данных, также включает обработку ошибок в случае удаления листка или ожидаемого имени. Пытался сделать его объяснительным с комментариями в коде, тем не менее, дайте мне знать о любом вопросе, который у вас может быть.

Sub Copy_Months_Data() 
Const kRowIni As Byte = 2 'Constant to hold the starting row, easy to update if required 
Dim aMonths As Variant 
aMonths = Array("January", "February", "March", "April", _ 
    "May", "June", "July", "August", _ 
    "September", "October", "November", "December") 
Dim WshSrc As Worksheet, WshTrg As Worksheet 
Dim rSrc As Range 
Dim lRowLst As Long, lRowNxt As Long 
Dim vItm As Variant 

    On Error GoTo ErrHdlr 

    Application.ScreenUpdating = 0 
    Application.EnableEvents = 0 

    With ThisWorkbook 'Procedure is resident in data workbook 
    'With Workbooks(WbkName) 'Procedure is no resident in data workbook 

     Rem Set & Prepare Target Worksheet - Results 
     vItm = "Results" 
     Set WshTrg = .Sheets(vItm) 'Change sheet name as required 
     With WshTrg 
      Application.Goto .Cells(1), 1 
      Rem Clear Prior Data 
      .Columns("A:B").ClearContents 
      lRowNxt = kRowIni 
     End With 

     For Each vItm In aMonths 

      Rem Set Source Worksheet - Each month 
      Set WshSrc = .Sheets(vItm) 
      With WshSrc 
       Rem Set Last Row for Columns A & B 
       lRowLst = .Cells(.Rows.Count, "A").End(xlUp).Row 
       If .Cells(.Rows.Count, "B").End(xlUp).Row > lRowLst Then _ 
        lRowLst = .Cells(.Rows.Count, "B").End(xlUp).Row 
       Set rSrc = .Range(.Cells(kRowIni, 1), .Cells(lRowLst, 2)) 
      End With 

      Rem Copy Range Values to Target Worksheet 
      With rSrc 
       WshTrg.Cells(lRowNxt, 1).Resize(.Rows.Count, .Columns.Count).Value = .Value2 
       lRowNxt = lRowNxt + .Rows.Count 
      End With 

    Next: End With 

    Application.ScreenUpdating = 1 
    Application.EnableEvents = 1 

Exit Sub 
ErrHdlr: 
    MsgBox prompt:="Process failed while processing worksheet """ & vItm & """ due to: " & vbLf & _ 
     vbTab & "Err: " & Err.Number & vbLf & _ 
     vbTab & "Dsc: " & Err.Description, _ 
     Buttons:=vbCritical + vbApplicationModal, _ 
     Title:="Copy Months Data" 

    Application.ScreenUpdating = 1 
    Application.EnableEvents = 1 

End Sub