Question

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

我无法调整此代码以适应我的电子表格，并希望得到一些帮助。我的工作表名称是col。 A（不是c），我只需要col。 B＆amp; C要复制到工作表。另外col。 B＆amp; C需要复制到col。 B＆amp; 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

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

1 个答案: