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

这是你的新主要子。它与您之前的代码基本没有变化，但我已将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指定为目标工作表的工作簿＆＃34; Berechnung_Personal＆＃34;找到了。如果没有制定规范，Excel会假定ActiveWorkbook。请注意，ThisWorkbook不必是ActiveWorkbook。 ThisWorkbook是包含代码的工作簿。在切换到VBE窗口或之后使用代码激活的工作簿之前，ActiveWorkbook是您查看的最后一个工作簿。

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将继续从它停止的位置开始计算 - 我希望如此。我没有测试循环。

复制单元格但不替换它们

2 个答案: