Excel VBA宏：搜索/查找/案例/查找？向下找到一列，然后再次搜索下一列，然后从第三列输出数据

Question

嗨有可能运行一个VB脚本来执行搜索一个10列数组16000行，查找数据部分匹配数据从一个单元格其中C列将有24个相同的数据，但D列中每个都有与D有关的从1到24的数字，当它从G和H列中找到日期并将其输出到其他地方时，将该数字与单元格进行比较。所以我认为它是这样的。

Sub LookupPCI01() 


Dim pf As Worksheet, pi As Worksheet, eq As Worksheet, ei As Worksheet, WS As Worksheet, exw As Worksheet 
Dim Rws As Long, I As Long, Rng As Range, c As Range, cr 
Dim FindPCI As String, OT As String, CT As String 
Dim vArray As Variant 


    Set pf = Sheets("PAR Form") 
    Set pi = Sheets("PAR_import") 
    Set eq = Sheets("Equipment details") 
    Set im = Sheets("IMAC Form") 
    Set ei = Sheets("Eq_import") 
    Set exw = Sheets("PCI_CW_EX") 




    Dim FirstAddress As String 


    With Application 
     .ScreenUpdating = False 
     .EnableEvents = False 
    End With 

     vArray = Array(Left(pf.Cells(cr, 13), 6)) 

     With exw 
     Rws = .Cells(.Rows.Count, "C").End(xlUp).Row 
     Set Rng = .Range(.Cells(2, "C"), .Cells(Rws, "C")) 


     If .Offset(0, 1) = pf.Cells(38) Then 

     For I = LBound(vArray) To UBound(vArray) 

      Set Rng = .Find(What:=vArray(I), _ 
          After:=.Cells(.Cells.Count), _ 
          LookIn:=xlFormula, _ 
          LookAt:=xlWhole, _ 
          SearchOrder:=xlByRows, _ 
          SearchDirection:=xlNext, _ 
          MatchCase:=False) 

      If Not Rng Is Nothing Then 
       FirstAddress = Rng.Address 
       Do 
        pi.Cells(cr + 14, 3).Value = Rng.Offset(0, 4).Value 
        pi.Cells(cr + 14, 4).Value = Rng.Offset(0, 5).Value 
        Set Rng = .FindNext(Rng) 
       Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress 
      End If 
     Next I 
    End With 

    With Application 
     .ScreenUpdating = True 
     .EnableEvents = True 
    End With 
End Sub 

Answer 1

Sub LookupPCI01() 

Dim pf As Worksheet, pi As Worksheet, eq As Worksheet, ei As Worksheet, WS As Worksheet, exw As Worksheet, op As Worksheet 
Dim Rws As Long, Rng As Range, c As Range, cr 
Dim ConTrue(1 To 3) As Integer 
Dim ExtractInfo() 
Dim CountArrayRow As Integer 

Set pf = Sheets("PAR Form") 
Set pi = Sheets("PAR_import") 
Set eq = Sheets("Equipment details") 
Set im = Sheets("IMAC Form") 
Set ei = Sheets("Eq_import") 
Set exw = Sheets("PCI_CW_EX") 
Set op = Sheets("OutP") 

On Error Resume Next 

ConTrue(1) = 1 
ConTrue(2) = 5 
ConTrue(3) = 9 

CountArrayRow = 0 

ReDim ExtractInfo(1 To ConTrue(3), 1 To 1) 


With exw 
    Rws = .Cells(.Rows.Count, 2).End(xlUp).Row 
Set Rng = .Range(.Cells(2, ConTrue(1)), .Cells(Rws, ConTrue(3))) 
End With 


For i = 1 To Rws 
    If exw.Cells(i, ConTrue(1) + 2).Value Like pi.Cells(16, 3) Then 
    CountArrayRow = CountArrayRow + 1 

''Redim everytime Finds that connection 
ReDim Preserve ExtractInfo(1 To ConTrue(3), 1 To CountArrayRow) 

''Copy to the Array 
    For J = 1 To ConTrue(3) 
     ExtractInfo(J, CountArrayRow) = exw.Cells(i, J).Value 
     Next J 
    End If 
    Next i  

''result of the array 
    For i = 1 To 9 
    For J = 1 To (CountArrayRow) 
     op.Cells(i, J) = ExtractInfo(i, J) 
    Next J 
    Next 

''search the value 02 

For i = 1 To CountArrayRow 
    If CInt(pf.Cells(2, 39).Value) = ExtractInfo(i, 4) Then 

    End If 
Next 

'PCI Export 

Dim PT As Integer 
PT = pi.Cells(16, 4).Value 

    pi.Cells(16, 3).Value = op.Cells(3, PT) 
    pi.Cells(50, 1).Value = op.Cells(7, PT) 
    pi.Cells(50, 2).Value = op.Cells(8, PT) 

End Sub