将数据从多张纸复制到一张纸的循环 [英] Loop that will copy Data from multiple sheets to one sheets

问题描述

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

I looked through the other questions, and couldn't find one to match my scenario.

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

I have multiple worksheets, and want to copy/paste into another Workbook/Worksheet called 'Markets'.

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

The next steps are to take the data out of "A1" and add those to Column A and B (respectively)

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

However, the copied data is currently pasting over the previous data. My formulas also are not dragging down to the end of the data.

    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...

推荐答案

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

Since I cannot test your code, I can see only two issues:

问题1 :您未在至少提供的代码中更新 aDestLastRow 和 cDestLastRow

Issue 1 You are not updating aDestLastRow and cDestLastRow in the code provided (at least)

问题2 :要分配 aDestLastRow 的值，您似乎忘记了对行进行 Offset 偏移.

Issue 2 To assign the value of aDestLastRow you seem to have forgotten to Offset the row by one.

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

A simple fix is to move these assignment into the loop. Another fix is to simply update the values of aDestLastRow and cDestLastRow by adding the number of copied rows, which I can see as CopyLastRow4 - 4, but obviously this needs to be tested. In the following code I moved the assigment lines into the code, which is the less efficient option. I hope this helps!

    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)

这篇关于将数据从多张纸复制到一张纸的循环的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！