将单元格的变量范围从一个表格复制到另一个表格

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和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