Question

Screenshot of what is happening here, for simplicity sake, I have changed the values to represent the columns that they rightfully belong in

我正在开发一个程序，我需要将多个工作表中的数据复制并重组为一个主数据库。每张一行。从列G到R我将需要设置一个if语句，这样如果工作表上的值大于0，它将被复制/粘贴到它的行中的下一个可用列。为了测试我已经删除了if语句，所以我总是得到一个结果。我遇到的问题是在第一行数据上“B”列被覆盖，后续行按预期工作。关于为什么会发生这种情况的任何想法？

    Sub CopyRangeFromMultiWorksheets()
    Dim sh As Worksheet
    Dim DestSh As Worksheet
    Dim LastR As Long
    Dim LastC As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the sheet "Master" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Master").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Master"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Master"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If sh.Name <> DestSh.Name Then

            'Find the last row with data on the DestSh
            With ActiveSheet
            LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
            End With

            With ActiveSheet
            LastC = .Cells(LastR, .Columns.Count).End(xlToLeft).Column
            End With                

            sh.Range("B2").Copy
            DestSh.Cells(LastR + 1, "A").PasteSpecial xlPasteValues   'customer'
            DestSh.Cells(LastR + 1, "B").Value = ("Glass")            'Product"
            DestSh.Cells(LastR + 1, "C").Value = sh.Name              'Color Name
            sh.Range("H32").Copy
            DestSh.Cells(LastR + 1, "D").PasteSpecial xlPasteValues   'based on QTY'
            DestSh.Cells(LastR + 1, "E").Value = ("Liters")           'based on Units'
            DestSh.Cells(LastR + 1, "F").Value = ("Clear")           'Base'

            sh.Range("F13").Copy
            DestSh.Cells(LastR + 1, LastC + 1).PasteSpecial xlPasteValues   'THIS IS THE LINE GIVING ME TROUBLE'

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    'AutoFit the column width in the DestSh sheet
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Answer 1

尝试将ActiveSheet替换为DestSh，可能这就是导致此问题的原因：

'Find the last row with data on the DestSh
With DestSh
    LastR = .Cells(.Rows.Count, "a").End(xlUp).Row
End With

With DestSh
    LastC = .Cells(LastR, .Columns.Count).End(xlToLeft).Column
End With

在您的情况下，LastC = .Cells(LastR, .Columns.Count).End(xlToLeft).Column不会返回父工作表中的最后一列，而是返回行LastR中的最后一列。试试这个真正的最后一栏：

LastC = LastRow(DestSh)

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

这值得一读 - https://www.rondebruin.nl/win/s9/win005.htm

Last Column命令间歇性地覆盖现有单元vba

1 个答案: