复制单元但不能replace它们
我卡在一个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 *”的工作表（还有另一个工作表），它将replace非相对输出单元目标的复制文件原因。
我想在最后复制的数据末尾继续使用新的工作表数据。
希望你得到什么即时通讯试图解释。
我build议你下面的代码重构
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
这是你的新主分。 它和你之前的代码基本没有什么ThisWorkbook ，但是我已经指定了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将继续从停止的地方开始计数 – 我希望。 我没有testing循环。
看看偏移function
如果您有任何问题，请告诉我。
好的编码！