將單元格的變量範圍從一個表格複製到另一個表格

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