vba - 数据未正确从一张纸复制到另一张纸

Question

Arrgg ...有人可以帮助我使用以下VBA吗？

这是循环浏览 5 张左右的工作表，如果工作表 DevList 中的列表上有任何名称，它会将它们复制到 OHD Leave Tracker 工作表。出于某种原因，第三列没有复制它找到的某些记录。这似乎是我用于工作表的数组，就好像我只放一个工作表名称一样，它工作正常。

或者，如果你能帮我找到更好的方法，因为这是在周五下午很快修补在一起的。

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