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

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

1 个答案: