复制单元格但不替换它们

Question

im stuck at a vba problem. i want to copy some cells from worksheet to another

first i go through all worksheets begin with "IT*"

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

    Call transfer

    End If
    Next ws

then call transfer

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 runs at all, but if there is another worksheet ( and there is another) named "IT*" it will replace the copied files cause of the non relative output cell destination.

I want to continue with the new worksheet data at the end of the last copied data.

Hope you get what im trying to explain.

Answer 1

I propose you the following refactoring of your code

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

And your main sub will call it as follows:

transferAP ws

Answer 2

This is your new Main sub. It is basically unchanged from your earlier code, but I have specified Wb to be ThisWorkbook . You may like to specify another.

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

In your TransferAP I have also specified ThisWorkbook as the workbook where the target worksheet "Berechnung_Personal" is found. Excel presumes the ActiveWorkbook if no specification is made. Note that ThisWorkbook needs not be the ActiveWorkbook. ThisWorkbook is the Workbook that contains the code. The ActiveWorkbook is the last workbook you looked at before switching to the VBE window or the workbook you activated using code thereafter.

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

The TransferAP returns the final value of R to the Main. So, when the next source worksheet is found R will continue counting from where it left off - I hope. I didn't test the loop.