Question

我需要找到VBA代码。我有2张“FinalData”和“ConsultantSheet”。在“FinalData”中，我有一个数据来自A列“名称”和B到R时间（1901行）。在“ConsultanatSheet”中，我有A1（名称）中的数据。我希望如果“FinalData”具有相同的名称，就像我在“ConsultantSheet”（B1）中所拥有的那样，并且在任何cloumn（B3 TO R3）中具有大于0的值，则从“Final Data”复制整行并粘贴它在A TO R的“ConsultantSheet”中，从ROW 2循环到ROW 1901 ......

先谢谢你的帮助！

Dim EmployeeType As String
Dim finalrow As Integer
Dim Duration As Integer
Dim i As Integer
Dim j As Integer

j = 2

Worksheets("Consultant Sheet").Range("A3:P2000").ClearContents
EmployeeType = Sheets("Consultant Sheet").Range("A1").Value 
finalrow = Sheets("Final Data").Range("B" & Rows.Count).End(xlUp).Row 

For i = 2 To finalrow 

    If Worksheets("Final Data").Cells(B, 2) = EmployeeType And _
       (Worksheets("Final Data").Cells(E, 2) > 0) Or _
       (Worksheets("Final Data").Cells(F, 2) > 0) Or _
       (Worksheets("Final Data").Cells(G, 2) > 0) Or _
       (Worksheets("Final Data").Cells(H, 2) > 0) Or _
       (Worksheets("Final Data").Cells(i, 2) > 0) Or _
       (Worksheets("Final Data").Cells(j, 2) > 0) Or _
       (Worksheets("Final Data").Cells(K, 2) > 0) Or _
       (Worksheets("Final Data").Cells(L, 2) > 0) Or _
       (Worksheets("Final Data").Cells(M, 2) > 0) Or _
       (Worksheets("Final Data").Cells(N, 2) > 0) Or _
       (Worksheets("Final Data").Cells(O, 2) > 0) Or _
       (Worksheets("Final Data").Cells(P, 2) > 0) Or _
       (Worksheets("Final Data").Cells(Q, 2) > 0) Or _
       (Worksheets("Final Data").Cells(R, 2) > 0) Then        
    Worksheets("Final Data").Cells(B, 2).Resize(1, 1000).Copy
    Worksheets("Final Data").Cells(j, "P").Resize(1, 1000).PasteSpecial xlPasteNumberFormats 
        j = j + 1
    End If 
Next i

End Sub

Answer 1

未测试：

Dim EmployeeType As String
Dim finalrow As Integer
Dim Duration As Integer
Dim i As Integer
Dim j As Integer
Dim shtCS As Worksheet, shtFD As Worksheet, rw As Range

Set shtCS = Worksheets("Consultant Sheet")
Set shtFD = Worksheets("Final Data")

j = 2

shtCS.Range("A3:P2000").ClearContents
EmployeeType = shtCS.Range("A1").Value
finalrow = shtFD.Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To finalrow

    Set rw = shtFD.Rows(i)

    If rw.Cells(, "B") = EmployeeType And _
        Application.CountIf(rw.Cells(, "E").Resize(1, 14), ">0") > 0 Then

        'EDITED: copy values only
        shtCS.Cells(j, 1).Resize(1, 50).value = rw.Cells(1).Resize(1, 50).Value
        j = j + 1

    End If
Next i

VBA通过匹配多列中的值来查找“复制”和“粘贴”

1 个答案: