Question

我浏览了其他问题，但找不到与我的情况相符的问题。

我有多个工作表，并且想要复制/粘贴到另一个名为“市场”的工作簿/工作表中。

下一步是将数据从“ A1”中取出，并将它们分别添加到列A和B中。

但是，当前复制的数据正在粘贴在先前的数据上。我的公式也没有下拉到数据的末尾。

    Dim Mkts As Worksheet
    Dim ws As Worksheet
    Dim aDestLastRow As Long
    Dim cDestLastRow As Long
    Dim FR As Range    'first row
    Dim LR As Range    'last row
    
        'Destination Worksheet
        Set Mkts = Workbooks("Nielsen SC Template.xlsm").Worksheets("Markets")
    
        'Find first blank row in the destination range based on data in Column A
        aDestLastRow = Mkts.Cells(Mkts.Rows.Count, "A").End(xlUp).Row
        
        'Find first blank row in the destination range based on data in Column C
        cDestLastRow = Mkts.Cells(Mkts.Rows.Count, "C").End(xlUp).Offset(1).Row

    
    'Copy 4Wk Data
        Dim Wb4 As Workbook
             Set Wb4 = Workbooks("4Wk Data.xlsx")
    
    For Each ws In Wb4.Worksheets
        With ws
            If .Index <> 1 Then
    
        'Find last used row in the copy range based on data in Column A
        Dim CopyLastRow4 As Long
            CopyLastRow4 = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If .Index = 2 Then
        'Copy and Paste Data into C3
            .Range("A4:V" & CopyLastRow4).Copy Mkts.Range("C" & cDestLastRow)
        
        'Add Dates
            Set FR = Mkts.Range("A" & cDestLastRow)
            Set LR = Mkts.Range("A" & aDestLastRow)
                Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report1'!$A$1, 9, 28)"
        'Add Markets
            Set FR = Mkts.Range("B" & cDestLastRow)
            Set LR = Mkts.Range("B" & aDestLastRow)
                Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report1'!$A$1, 48, 13)"
        End If
        
        If .Index = 3 Then
        'Copy and Paste Data
            .Range("A4:V" & CopyLastRow4).Copy Mkts.Range("C" & cDestLastRow)

etc...

Answer 1

由于我无法测试您的代码，因此只能看到两个问题：

问题1 （至少）您没有在提供的代码中更新aDestLastRow和cDestLastRow

问题2 ：要分配aDestLastRow的值，您似乎忘记了Offset一行。

一个简单的解决方法是将这些分配移入循环。另一个解决方法是通过添加复制的行数来简单地更新aDestLastRow和cDestLastRow的值，我可以将其视为CopyLastRow4 - 4，但是显然这需要进行测试。在下面的代码中，我将分配行移到了代码中，这是效率较低的选项。我希望这会有所帮助！

    Dim Mkts As Worksheet
    Dim ws As Worksheet
    Dim aDestLastRow As Long
    Dim cDestLastRow As Long
    Dim FR As Range    'first row
    Dim LR As Range    'last row
    
        'Destination Worksheet
        Set Mkts = Workbooks("Nielsen SC Template.xlsm").Worksheets("Markets")
    
    'Copy 4Wk Data
        Dim Wb4 As Workbook
             Set Wb4 = Workbooks("4Wk Data.xlsx")
    
    For Each ws In Wb4.Worksheets
        '*****Moved these lines into loop
        '*****You forgot to offset the first assignment
        'Find first blank row in the destination range based on data in Column A
        aDestLastRow = Mkts.Cells(Mkts.Rows.Count, "A").End(xlUp).Row + 1
        
        'Find first blank row in the destination range based on data in Column C
        cDestLastRow = Mkts.Cells(Mkts.Rows.Count, "C").End(xlUp).Offset(1).Row
        '******End of edit
        
        With ws
            If .Index <> 1 Then
    
        'Find last used row in the copy range based on data in Column A
        Dim CopyLastRow4 As Long
            CopyLastRow4 = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        If .Index = 2 Then
        'Copy and Paste Data into C3
            .Range("A4:V" & CopyLastRow4).Copy Mkts.Range("C" & cDestLastRow)
        
        'Add Dates
            Set FR = Mkts.Range("A" & cDestLastRow)
            Set LR = Mkts.Range("A" & aDestLastRow)
                Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report1'!$A$1, 9, 28)"
        'Add Markets
            Set FR = Mkts.Range("B" & cDestLastRow)
            Set LR = Mkts.Range("B" & aDestLastRow)
                Range(FR, LR).Formula = "=Mid('[4Wk Data.xlsx]Report1'!$A$1, 48, 13)"
        End If
        
        If .Index = 3 Then
        'Copy and Paste Data
            .Range("A4:V" & CopyLastRow4).Copy Mkts.Range("C" & cDestLastRow)

将数据从多张纸复制到一张纸的循环

1 个答案: