复制单元格但不替换它们

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将从其中断处继续计数-我希望。 我没有测试循环。