VBA代码调整 - 循环，复制到新工作表

Question

我有以下来自Chandoo for excel的代码。在"数据表"中，它根据 col. C 选择要复制到的工作表，然后复制 col。A - G 到该电子表格并移动到下一个条目。

我在调整此代码以适应我的电子表格时遇到问题，希望得到一些帮助。我的工作表名称在列中。A（不是c），我只需要将B和C上校复制到工作表中。此外，B&C上校需要复制到电子表格中的B&G上校中。

Sub copyPasteData()
    Dim strSourceSheet As String
    Dim strDestinationSheet As String
    Dim lastRow As Long
    strSourceSheet = "Data entry"
    Sheets(strSourceSheet).Visible = True
    Sheets(strSourceSheet).Select
    Range("C2").Select
    Do While ActiveCell.Value <> ""
        strDestinationSheet = ActiveCell.Value
        ActiveCell.Offset(0, -2).Resize(1, ActiveCell.CurrentRegion.Columns.Count).Select
        Selection.Copy
        Sheets(strDestinationSheet).Visible = True
        Sheets(strDestinationSheet).Select
        lastRow = LastRowInOneColumn("A")
        Cells(lastRow + 1, 1).Select
        Selection.PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        Sheets(strSourceSheet).Select
        ActiveCell.Offset(0, 2).Select
        ActiveCell.Offset(1, 0).Select
    Loop
End Sub
Public Function LastRowInOneColumn(col)
    'Find the last used row in a Column: column A in this example
    'http://www.rondebruin.nl/last.htm
    Dim lastRow As Long
    With ActiveSheet
    lastRow = .Cells(.Rows.Count, col).End(xlUp).Row
    End With
    LastRowInOneColumn = lastRow
End Function

如能协助解决这个问题，将不胜感激。

谢谢

Answer 1

这是关于从互联网上复制随机代码的危险的启示。 像这样操作活动选择很慢，难以阅读且难以维护。

下面是重构的代码，以便在更可控的版本中执行此任务。

包含原始代码（重构），注释掉。 修改为引用您请求的单元格的代码遵循每个原始行

Sub copyPasteData()
    Dim strSourceSheet As String
    Dim strDestinationSheet As String
    Dim lastRow As Long
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim rWs As Range
    Dim rSrc As Range, rDst As Range, cl As Range
    strSourceSheet = "Data entry"
    ' Get a reference to the source sheet
    Set wsSource = Worksheets(strSourceSheet)
    With wsSource
        ' Get a reference to the list of sheet names
        'Set rWs = Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))  ' for Column C
        Set rWs = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))  ' for Column A
        ' Loop through the sheet names list
        For Each cl In rWs.Cells
            ' Get a reference to the current row of data, all cells on that row
            'Set rSrc = cl.EntireRow.Resize(1, .Cells(cl.Row, .Columns.Count).End(xlToLeft).Column)
            Set rSrc = cl.EntireRow.Cells(1, 2).Resize(1, 2)  ' Reference columns B and C only
            ' Get a reference to the current Destination sheet
            Set wsDest = Worksheets(cl.Value)
            With wsDest
                lastRow = .Cells(.Rows.Count, 2).End(xlUp).Row  ' Check last row in Column B
                ' Copy data to destination using Value array
                '.Cells(lastRow + 1, 1).Resize(1, rSrc.Columns.Count).Value = rSrc.Value  ' all data
                .Cells(lastRow + 1, 2).Value = rSrc.Cells(1, 1) ' copy first cell to column B
                .Cells(lastRow + 1, 7).Value = rSrc.Cells(1, 2) ' copy second cell to column G
            End With
        Next
    End With
End Sub