Vba 数据未正确地从一张图纸复制到另一张图纸

啊。。。有人能帮我做下面的VBA吗

循环浏览5张左右的工作表，如果工作表列表中有任何姓名，则将其复制到OHD休假跟踪表中。出于某种原因，第三列没有复制它找到的某些记录。这似乎是我用于工作表的数组，好像我只在那里输入了一个工作表名称，它工作得很好

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

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

---

问题在于你的数据。没有理由认为您的代码在所有情况下都应该工作相同

这里有一个更好的方法：

• 使用数组收集数据，然后在一次操作中写入所有数据
• 使用集合筛选出DevList中存在的值
• 我在第3列中的值为空时添加了一行，该行将停止代码执行
  • 调试。断言修剪（.Cells（1，3））“”

---

子副本是（）
变暗启动：启动=计时器
调光范围
作为整数的Dim j
将源设置为工作表，将目标设置为工作表
Dim arrData作为变量：ReDim arrData（2，0）
Dim DevList As Object:Set DevList=CreateObject（“System.Collections.ArrayList”）
带工作表（“开发列表”）
对于每个c In.范围（“A1”、.Range（“A”&行数）.End（xlUp））
DevList.添加c.文本
下一个c
以
对于工作表中的每个源（数组（“Ind”、“FAP”、“YEE”、“ABY”、“LSL”、“OHD”））
设置目标=活动工作簿。工作表（“OHD休假跟踪程序”）
有来源
对于.Range中的每个c（“F1”、.Range（“F”&行数）.End（xlUp））
如果c=“已批准”，则
用c.EntireRow
如果不是DevList.Contains（.Cells（1,2）.Text），则
雷迪姆数据（2，j）
arrData（0，j）=.个单元（1，1）
arrData（1，j）=.个单元（1，2）
arrData（2，j）=.个单元（1，3）
调试。断言修剪（.Cells（1，3））“”
j=j+1
如果结束
以
如果结束
下一个c
以
下一个来源
Target.Range（“B6:D”和Rows.Count）。清除
Target.Range（“B6:D6”）.Resize（j）=应用程序转置（arrData）
打印计时器-启动
端接头

很难说清你指的是什么。我假设复制数据在第一个循环中失败，但是没有任何DevList引用任何数组元素。代码的哪一部分失败了？也许可以先尝试更改它。我清理了代码，但我现在不会发布。Lastrow=Target.Range（“B”&Rows.Count）.End（xlUp）.Row'添加了对OHD休假表的引用抱歉，我忘了提到我在OHD休假跟踪表的a列中添加了一个助手列，然后在DevList表中做了一个VLookup不走运，上校，谢谢编辑Shai Rado。我忘了我有那个参考。谢谢Thomas，这基本上是可行的，但是行

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