数据不能正确地从一张纸复印到另一张纸上

Arrgg …任何人都可以帮助我与下面的VBA？

这是循环5张左右的工作表，如果在工作表DevList中列表中有任何名字，它将把它们复制到OHD工作logging表。 由于某些原因，第三列没有复制它find的一些logging。 这似乎是我用于床单的数组，就好像我只把一个工作表名称，它工作正常。

或者，如果你能帮助我find一个更好的方法，因为这周五下午相当快地补丁。

Sub CopyYes() Dim c As Range Dim thisrow As Variant Dim j As Integer Dim Source As Worksheet Dim Target As Worksheet Dim arr As Variant arr = Array("Ind", "FAP", "YEE", "ABY", "LSL", "OHD's") j = 6 ' Start copying to row 6 in target sheet For i = LBound(arr) To UBound(arr) ' Change worksheet designations as needed 'Set Source = Worksheets(arr(i)) Set Target = ActiveWorkbook.Worksheets("OHD Leave Tracker") For Each c In Worksheets(arr(i)).Range("F1:F1000") ' Do 1000 rows If c = "Approved" Then thisrow = c.Row Target.Cells(j, 2) = Worksheets(arr(i)).Cells(thisrow, 1) Target.Cells(j, 3) = Worksheets(arr(i)).Cells(thisrow, 2) Target.Cells(j, 4) = Worksheets(arr(i)).Cells(thisrow, 3) j = j + 1 End If Next c Next i Dim Lastrow As Long Lastrow = Range("B" & Rows.Count).End(xlUp).Row Worksheets("OHD Leave Tracker").Range("A6:A" & Lastrow).Formula = "=IF(ISERROR(VLOOKUP(B6,DevList!A:A,1,FALSE)),""Delete"",""Keep"")" Last = Worksheets("OHD Leave Tracker").Cells(Rows.Count, "A").End(xlUp).Row For i = Last To 1 Step -1 If Worksheets("OHD Leave Tracker").Cells(i, "A").Value = "Delete" Then Worksheets("OHD Leave Tracker").Cells(i, "A").EntireRow.Delete End If Next i End Sub 

Answer 1

问题在于你的数据。 没有理由，你的代码不应该在所有情况下都一样。

这是一个更好的方法：

• 使用数组收集数据，然后在一个操作中写入所有数据
• 使用集合来过滤DevList中存在的值
• 我添加了一行会停止代码执行的第3列中的值为空
  • Debug.Assert Trim（.Cells（1，3））<>“”

---

 Sub CopyYes() Dim Start: Start = Timer Dim c As Range Dim j As Integer Dim Source As Worksheet, Target As Worksheet Dim arrData As Variant: ReDim arrData(2, 0) Dim DevList As Object: Set DevList = CreateObject("System.Collections.ArrayList") With Worksheets("DevList") For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp)) DevList.Add c.Text Next c End With For Each Source In Worksheets(Array("Ind", "FAP", "YEE", "ABY", "LSL", "OHD's")) Set Target = ActiveWorkbook.Worksheets("OHD Leave Tracker") With Source For Each c In .Range("F1", .Range("F" & Rows.Count).End(xlUp)) If c = "Approved" Then With c.EntireRow If Not DevList.Contains(.Cells(1, 2).Text) Then ReDim Preserve arrData(2, j) arrData(0, j) = .Cells(1, 1) arrData(1, j) = .Cells(1, 2) arrData(2, j) = .Cells(1, 3) Debug.Assert Trim(.Cells(1, 3)) <> "" j = j + 1 End If End With End If Next c End With Next Source Target.Range("B6:D" & Rows.Count).Clear Target.Range("B6:D6").Resize(j) = Application.Transpose(arrData) Debug.Print Timer - Start End Sub