復制單元格但不替換它們

Question

我陷入了VBA問題。 我想將一些單元格從工作表復制到另一個

首先，我瀏覽所有工作表均以“ IT *”開頭

For Each ws In wb.Worksheets
    If ws.Name Like "IT*" Then
    ws.Select

    Call transfer

    End If
    Next ws

然后來電轉接

Sub transferAP()
'
' transferAP Makro
'

    Dim strSheetName As String
    strSheetName = ActiveSheet.Name


    Sheets(strSheetName).Select

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A3")
    Worksheets(strSheetName).Range("E9").Copy Worksheets("Berechnung_Personal").Range("B3")
    Worksheets(strSheetName).Range("G9").Copy Worksheets("Berechnung_Personal").Range("C3")
    Worksheets(strSheetName).Range("G11").Copy Worksheets("Berechnung_Personal").Range("D3")


    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A4")
    Worksheets(strSheetName).Range("E24").Copy Worksheets("Berechnung_Personal").Range("B4")
    Worksheets(strSheetName).Range("G24").Copy Worksheets("Berechnung_Personal").Range("C4")
    Worksheets(strSheetName).Range("G26").Copy Worksheets("Berechnung_Personal").Range("D4")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A5")
    Worksheets(strSheetName).Range("E39").Copy Worksheets("Berechnung_Personal").Range("B5")
    Worksheets(strSheetName).Range("G39").Copy Worksheets("Berechnung_Personal").Range("C5")
    Worksheets(strSheetName).Range("G41").Copy Worksheets("Berechnung_Personal").Range("D5")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A6")
    Worksheets(strSheetName).Range("M3").Copy Worksheets("Berechnung_Personal").Range("B6")
    Worksheets(strSheetName).Range("O3").Copy Worksheets("Berechnung_Personal").Range("C6")
    Worksheets(strSheetName).Range("O5").Copy Worksheets("Berechnung_Personal").Range("D6")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A7")
    Worksheets(strSheetName).Range("M18").Copy Worksheets("Berechnung_Personal").Range("B7")
    Worksheets(strSheetName).Range("O18").Copy Worksheets("Berechnung_Personal").Range("C7")
    Worksheets(strSheetName).Range("O20").Copy Worksheets("Berechnung_Personal").Range("D7")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A8")
    Worksheets(strSheetName).Range("M33").Copy Worksheets("Berechnung_Personal").Range("B8")
    Worksheets(strSheetName).Range("O33").Copy Worksheets("Berechnung_Personal").Range("C8")
    Worksheets(strSheetName).Range("O35").Copy Worksheets("Berechnung_Personal").Range("D8")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A9")
    Worksheets(strSheetName).Range("U3").Copy Worksheets("Berechnung_Personal").Range("B9")
    Worksheets(strSheetName).Range("W3").Copy Worksheets("Berechnung_Personal").Range("C9")
    Worksheets(strSheetName).Range("W5").Copy Worksheets("Berechnung_Personal").Range("D9")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A10")
    Worksheets(strSheetName).Range("U18").Copy Worksheets("Berechnung_Personal").Range("B10")
    Worksheets(strSheetName).Range("W18").Copy Worksheets("Berechnung_Personal").Range("C10")
    Worksheets(strSheetName).Range("W20").Copy Worksheets("Berechnung_Personal").Range("D10")

    Worksheets(strSheetName).Range("C3").Copy Worksheets("Berechnung_Personal").Range("A11")
    Worksheets(strSheetName).Range("U33").Copy Worksheets("Berechnung_Personal").Range("B11")
    Worksheets(strSheetName).Range("W33").Copy Worksheets("Berechnung_Personal").Range("C11")
    Worksheets(strSheetName).Range("W35").Copy Worksheets("Berechnung_Personal").Range("D11")

它完全可以運行，但是如果存在另一個名為“ IT *”的工作表（並且存在另一個工作表），它將替換復制的文件，從而導致非相對輸出單元格目標。

我想在最后復制的數據的末尾繼續使用新的工作表數據。

希望你得到我試圖解釋的東西。

Answer 1

我建議您對代碼進行以下重構

Sub transferAP(sourceSht As Worksheet)
    With Worksheets("Berechnung_Personal") '<--| reference target sheet
        With .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '<--| reference its column A first empty cell after last not empty one)
            sourceSht.Range("C3").Copy .Cells(1,1)
            sourceSht.Range("E9").Copy .Cells(2,1)
            sourceSht.Range("G9").Copy .Cells(3,1)

            .... and so on: keep in mind that .Cells(1,1) syntax assumes the referenced range as the starting cell 
        End With 
    End With 
End Sub

您的主要子對象將按以下方式調用它：

transferAP ws

Answer 2

這是您的新Main子項。 與您之前的代碼基本沒有什么不同，但是我將Wb指定為ThisWorkbook 。 您可能想指定另一個。

Sub Main()

    Dim Wb As Workbook
    Dim Ws As Worksheet
    Dim R As Long

    Set Wb = ThisWorkbook
    For Each Ws In Wb.Worksheets
        If Ws.Name Like "IT*" Then
            TransferAP Ws, R           ' pass the Ws to the sub
        End If
    Next Ws
End Sub

在您的TransferAP中，我還指定ThisWorkbook作為工作簿，在其中找到目標工作表“ Berechnung_Personal”。 如果未指定規格，則Excel將假定ActiveWorkbook。 請注意，ThisWorkbook不必是ActiveWorkbook。 ThisWorkbook是包含代碼的工作簿。 ActiveWorkbook是您切換到VBE窗口之前查看的最后一個工作簿，或之后使用代碼激活的工作簿。

Sub TransferAP(Ws As Worksheet, R As Long)
    ' 21 Mar 2017

    Dim WsTarget As Worksheet
    Dim Sources() As String             ' List of source cells
    Dim i As Integer                    ' index for Sources

    Set WsTarget = ThisWorkbook.Worksheets("Berechnung_Personal")
    If R = 0 Then R = 3                 ' row 3 is the first row to use

    Sources = Split("E9,E24,E39,M3,M18,M33,U3,U18,U33", ",")
    For i = 0 To UBound(Sources)
        With WsTarget
            .Cells(R, 1).Value = Ws.Range("C3").Value
            .Cells(R, 2).Value = Ws.Range(Sources(i)).Value
            .Cells(R, 3).Value = Ws.Range(Sources(i)).Offset(0, 2).Value
            .Cells(R, 4).Value = Ws.Range(Sources(i)).Offset(2, 2).Value
        End With
        R = R + 1
    Next i
 End Sub

TransferAP將R的最終值返回給Main。 因此，當找到下一個源工作表時，R將從其中斷處繼續計數-我希望。 我沒有測試循環。