利用VBA找到满足两个条件的值

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, vTemp, i&, j&, r&, isFlag As Boolean
   
    Application.ScreenUpdating = False
   
    ar = [A1].CurrentRegion.Value
    ReDim br(2 To 3)
    ReDim cr(1 To 2)
    For i = 2 To 3
        br(i) = Worksheets(i).[A1].CurrentRegion.Value
    Next i
    With Worksheets(1)
        ar = .[A1].CurrentRegion.Value
        For i = 1 To UBound(ar)
            isFlag = False
            For j = 4 To UBound(br(2))
                If br(2)(j, 6) = ar(i, 3) Then
                    vTemp = br(2)(j, 13)
                    isFlag = True: Exit For
                End If
            Next j
            If isFlag Then
                For j = 2 To UBound(br(3))
                    If br(3)(j, 5) = ar(i, 3) Then
                        ar(i, 10) = vTemp
                        ar(i, 11) = br(3)(j, 8)
                        Exit For
                    End If
                Next j
            End If
        Next i
        With .[A1].CurrentRegion
            .Columns(3).NumberFormatLocal = "@"
            .Value = ar
        End With
        .Activate
    End With
        
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

。。。。。。。。。

ykcbf1100

一招秒杀 发表于 2024-8-18 08:27
我只是扫了一眼，没仔细看，没留意到，所有的需求，其实用SQL来解决，1条语句就能全部搞定，哪里需要 ...

那你上个SQL的呗。
你最好接地气一点，在VBA版块，用VBA的SQL来解决一下问题。

Qs18

    .Range("a" & UBound(arr) + 2).Resize(rw, UBound(arr, 2)) = drr

Qs18

Sub qs()
Dim arr, brr, crr, i, dic As Object
Set dic = CreateObject("scripting.dictionary")
brr = Sheet2.Range("a1").CurrentRegion.Value
For i = 4 To UBound(brr)
    s = brr(i, 3) & "|" & brr(i, 6)
    dic(s) = brr(i, 13)
Next
s = ""
crr = Sheet3.Range("a1").CurrentRegion.Value
For i = 2 To UBound(crr)
    s = crr(i, 4) & "|" & crr(i, 5)
    If Not dic.exists(s) Then
        dic(s) = "" & "|" & crr(i, 8)
    Else
        dic(s) = dic(s) & "|" & crr(i, 8)
    End If
Next
On Error Resume Next
arr = Sheet1.Range("a2:k" & Sheet1.Cells(Rows.Count, 2).End(xlUp).Row)
ReDim drr(1 To UBound(arr), 1 To UBound(arr, 2))
For Each k In dic.keys
    m = 0
    For i = 1 To UBound(arr)
        t = arr(i, 2) & "|" & arr(i, 3)
        If t = k Then
            arr(i, 10) = Split(dic(t), "|")(0)
            arr(i, 11) = Split(dic(t), "|")(1)
            m = m + 1
            GoTo 100
        End If

    Next
100
        If m = 0 Then
            rw = rw + 1
            drr(rw, 2) = Split(k, "|")(0)
            drr(rw, 3) = "'" & Split(k, "|")(1)
            drr(rw, 10) = Split(dic(k), "|")(0)
            drr(rw, 11) = Split(dic(k), "|")(1)
            drr(rw, 9) = "没有名字"
        End If
Next
With Sheet1
    .Range("j2").Resize(UBound(arr), 1) = Application.Index(arr, 0, 10)
    .Range("k2").Resize(UBound(arr), 1) = Application.Index(arr, 0, 11)
    .Range("a" & UBound(arr) + 2).Resize(10000, UBound(arr, 2)) = ""
    .Range("a" & UBound(arr) + 2).Resize(rw, UBound(arr, 2)) = drr
End With
MsgBox "完成！"
End Sub

Qs18

试试............

Qs18

试试..........

一招秒杀

ykcbf1100 发表于 2024-8-18 08:49
那你上个SQL的呗。
你最好接地气一点，在VBA版块，用VBA的SQL来解决一下问题。

直接以表2为基础，加多一列，XLookup就够了，何必搞出什么表1，多此一举，更简单了，更不用SQL了。