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））＆lt;＆gt; “”

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

数据没有正确地从一张纸复制到另一张纸

1 个答案:

这是一个更好的方法：