使用 VBA 從兩個不同的工作表復制粘貼單元格

Question

這是我下面的代碼，它的工作原理只是不確定為什么當它復制到第二列和第三列時它會向下移動一行。

Dim shB As Worksheet, shPM As Worksheet, lastRowB As Long, lastRowPM As Long
 Dim shC As Worksheet, shD As Worksheet
 Dim i As Long, lastCol As Long
 Dim eRow As Long

 Set shB = Worksheets("Billable")
 Set shPM = Worksheets("PM_Forecast")

 lastRowB = Worksheets("Billable").Cells(Rows.Count, 1).End(xlUp).Row

 ''Loop will run from row 6 to the last row (Row 6 is the first row in table)
 For i = 6 To lastRowB
    ''Check Billable requests first
    If shB.Cells(i, 15).Value = "Detailed Estimate Submitted" Then
        ''Copy over ID reference
        shB.Cells(i, 2).Copy
        eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
        shB.Paste Destination:=shPM.Cells(eRow + 1, 1)
        ''Copy over title
        shB.Cells(i, 3).Copy
        eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
        shB.Paste Destination:=shPM.Cells(eRow + 1, 2)
        ''Copy over Effort
        shB.Cells(i, 9).Copy
        eRow = shPM.Cells(Rows.Count, 1).End(xlUp).Row
        shB.Paste Destination:=shPM.Cells(eRow + 1, 3)

下一個結束

這是結果的圖片，也許有人可以告訴我哪里出錯了。

Answer 1

嘗試粘貼到下一列時，不要每次都計算eRow （基於 A:A 列）。

每次迭代使用shB.Paste Destination:=shPM.Cells(eRow, 2) （不是eRow + 1 ）。

否則，A 列中的新添加值：A 將向eRow添加另一行 ...

或者計算每列的最后一行：

eRow = shPM.Cells(Rows.Count, 2).End(xlUp).Row和eRow = shPM.Cells(Rows.Count, 3).End(xlUp).Row ，根據您要復制的列價值。

Answer 2

您可以使用Union簡化代碼，並將下一個空單元格變量放在If語句中，以便重新計算每個循環。

'Define your sheet variables. `ThisWorkbook` means, the workbook in which the excel code is in. 
Dim wsSrce As Worksheet: Set wsSrce = ThisWorkbook.Sheets("Billable")
Dim wsDest As Worksheet: Set wsDest = ThisWorkbook.Sheets("PM_Forecast")

'Define the last row variable in the source sheet
Dim lRowSrce As Long: lRowSrce = wsSrce.Cells(Rows.Count, 1).End(xlUp).Row

    With wsSrce
        For i = 6 To lRowSrce

            'test each row for the data in Column O.
            If .Cells(i, 15).Value = "Detailed Estimate Submitted" Then

                'Define the next empty row variable in the destination sheets, within your IF statement
                Dim NxtEpty As Long: NxtEpty = wsDest.Cells(Rows.Count, 1).End(xlUp).Offset(1).Row

                'Use Union to combine the noncontinuous ranges in each row and paste to the next empty cell in the destination sheet
                Union(.Cells(i, 2), .Cells(i, 3), .Cells(i, 9)).Copy Destination:=wsDest.Cells(NxtEpty, 1)
            End If
        Next i
    End With