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

＆＃39;以上应该设置每张表中的数据范围（我希望）＆＃39;然后我运行以下

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

我需要的信息存储在A列和A列中。 B所以我们试图复制它们。

任何人都可以帮忙吗？

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

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

2 个答案: