VBA宏-使用复制粘贴指定列。

Question

我有一个部分工作的VBA宏，它在第41列（“ GRADED”和“ UNGRADED”）中找到字符串的情况下，将其从一张工作表“ AverageEarnings”复制到两张工作表（“ SicknessRecordGraded”，“ SicknessRecordUngraded”）中。
我希望宏从第3行将值从B，C列（“ AverageEarnings”）复制到其他工作表的A，B列。
目前，它正在将B，C，D列复制到第三行另一张纸上的A，B，C列。
此外，我从初始工作表中接收到太多值，其中有4957个。这是我的宏。

Public Sub CopyRowsSickness()

' This macro will copy rows in AverageEarnings spreadsheet, to Sheet1 if Ungraded (Column AO) or to Sheet2 if Graded.

    ' Insert message box to warn user.
    If MsgBox("This could take some time. (5 - 10 mins). Proceed?", vbYesNo) = vbNo Then Exit Sub

    ' Select initial sheet to copy from
    Sheets("AverageEarnings").Select
    ' Find the last row of data - xlUp will check from the bottom of the spreadsheet up.
    FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
    ' For loop through each row
    For x = 1 To FinalRow

        ThisValue = Cells(x, 41).Value    ' The value to check is located in Column AO or 41.

        If ThisValue = "UNGRADED" Then    ' If the value is Ungraded
            Cells(x, 2).Resize(5000, 3).Copy ' Resize from intial range.
            Sheets("SicknessRecordUngraded").Select    ' Specify first sheet to copy to.
             NextRow = Cells(3, 3).End(xlUp).Row + 1    '   <-- This line instead of next if you dont want paste over top.
            'NextRow = Cells.Row + 1
            ' Rows.Count, 1
            Cells(NextRow, 1).Select ' Find the next row.
            ActiveSheet.Paste ' Paste information.
            Sheets("AverageEarnings").Select 'Reselect sheet to copy from.

        ElseIf ThisValue = "GRADED" Then
            Cells(x, 2).Resize(5000, 3).Copy
            Sheets("SicknessRecordGraded").Select
            NextRow = Cells(3, 3).End(xlUp).Row + 1
            'NextRow = Cells.Row + 1 ' Increment row.
            ' Rows.Count, 1
            Cells(NextRow, 1).Select
            ActiveSheet.Paste
            Sheets("AverageEarnings").Select

        End If
    Next x
End Sub

我知道问题出在这两行的值之内。 我已将它们修改为各种不同的值，但尚未解决。 与“ AverageEarnings”中的值相比，它似乎粘贴了更多的值。

Cells(x, 2).Resize(5000, 3).Copy

NextRow = Cells(3, 3).End(xlUp).Row + 1

Answer 1

在复制之前，您正在将要复制的范围调整为5000行乘3列：

Cells(x, 2).Resize(5000, 3).Copy

如果只想从该行的B和C列复制数据，则只需将大小调整为1行乘2列：

Cells(x, 2).Resize(1, 2).Copy

已更新，以获取有关始终将数据粘贴到行3中的注释。粘贴数据时，该行被标识为：

NextRow = Cells(3, 3).End(xlUp).Row + 1

它从单元格C3开始，在当前区域内向上移动（就像按END + UP），然后向下移动1行。 这意味着，如果您在C2中有一个标题行，然后是数据，则最终返回到单元格C3以粘贴数据。 假设您的桌子下面没有东西，我建议：

NextRow =单元格（1048576，3）.End（xlUp）.Row + 1

这将从底部开始，以查找包含数据的最后一行，然后采用该行下方的单元格。 您可能需要根据Excel版本中可用的行数来调整“单元格”属性的行值（1048576）。