Question

经过大量的谷歌搜索和尝试后，我要求您提供有关以下问题的帮助。

工作表1 （数据库） ID 以及 D列
工作表2 （技能）第1行中的 ID 和所有各自的技能每个ID列的行。
填充列表框和图表需要工作表3（输出），可以视为空

通过组合框，用户正在寻找的技能 已选中。此然后需要匹配 工作表2 每个ID 的技能 >。

如果找到匹配，则相应的ID应在工作表1 上找到，某些信息从那里复制到工作表3

我对此的看法是找到工作表1中的每个ID，将其与工作表2上的所有ID相匹配，并查看相应的行以进行匹配。但是，欢迎采用更有效的方式。

这是我的代码：

组合框

Dim wb As Workbook
Set wb = ActiveWorkbook
Dim ws1, ws2, ws3, ws4 As Worksheet
Set ws1 = wb.Worksheets("Meta DB")
Set ws2 = wb.Worksheets("Criteria")
Set ws3 = wb.Worksheets("Supplier Criteria TreeView")
Set ws4 = wb.Worksheets("Supplier Skills")

'1. - - get all Suppliers for the selected Input
'Redefine for clarity
Dim strFind As String

'1.0. - - Clear previously used ranges
ws3.Range("A2:L28").Clear
ws3.Range("A30:L100").Clear
ws3.Range("V2:V20").Clear

'1.1. - - Get value to search for and range to go through (depending on combobox selections)
If Me.comboProduct.ListIndex = -1 And Me.comboSubGroup.ListIndex = -1 And Me.comboCG.ListIndex <> -1 Then
    strFind = Me.comboCG.value
ElseIf Me.comboProduct.ListIndex = -1 And Me.comboSubGroup.ListIndex <> -1 And Me.comboCG.ListIndex <> -1 Then
    strFind = Me.comboSubGroup.value
ElseIf Me.comboProduct.ListIndex <> -1 And Me.comboSubGroup.ListIndex <> -1 And Me.comboCG.ListIndex <> -1 Then
    strFind = Me.comboProduct.value
End If

尝试1：

Dim rng1, rng2 As Range
Dim lRow, j, k As Long
Dim IDrow As String

'Paste starting at row 2 or 30 in ws3, respectively (Active / Inactive)
j = 2
k = 30

For Each rng1 In ws1.Range("D4:D500")
    If Rng <> "" Then
        For Each rng2 In ws4.Range("A1:ZZ1")
            If rng2 <> "" Then
                If rng1.value = rng2.value Then
                    For lRow = 2 To ws4.UsedRange.Rows.Count
                        IDrow = ws4.Cells(lRow, rng2).value
                        If InStr(1, IDrow, strFind, vbTextCompare) > 0 Then
                            'Check for active Supplier in current Database-row
                            If ws1.Range("E" & rng1) = "Yes" Then
                                'Copy row of Database to row j of ws3 then increment j
                                ws1.Range("B" & rng1 & ":" & "E" & rng1).Copy Destination:=ws3.Range("B" & j & ":" & "E" & j) 'Copy Name, Potential Supplier, ID, Active
                                j = j + 1
                            'ElseIf inactive Supplier, post further down from 30 onwards. Second listbox populates from there
                            ElseIf ws1.Range("E" & rng1) = "No" Then
                                ws1.Range("B" & rng1 & ":" & "E" & rng1).Copy Destination:=ws3.Range("B" & k & ":" & "E" & k) 'Copy Name, Potential Supplier, ID, Active
                                k = k + 1
                            Else
                                Exit Sub
                            End If
                        End If
                    Next lRow
                End If
            End If
        Next rng2
    End If
Next rng1

尝试2：

Dim IDAr, MyAr, TempAr As Variant
Dim lRow, lastRow, entryrow, LCol, e As Long
Dim ColumnLetter As String

entryrow = ws3.Range("B" & Rows.Count).End(xlUp).row + 1

ws1LRow = ws1.Range("D" & ws1.Rows.Count).End(xlUp).row
IDAr = ws1.Range("D4:D" & lRow).value


Set f = ws4.Range("A1:ZZ1").Find(What:=IDAr, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=False)
ColumnLetter = Split(f.Address, "$")(1)

lastRow = ws4.Range(ColumnLetter & "2:" & ColumnLetter & "50").End(xlUp).row

MyAr = ws4.Range(ColumnLetter & "1:" & ColumnLetter & lastRow).value

With ws3
    'If IsArray(MyAr) Then
        For i = LBound(MyAr) To UBound(MyAr)
            TempAr = Split(MyAr(i, 1), "\")
            For e = 0 To 2
                TempAr(e) = ValueToCompare
                    If InStr(1, ValueToCompare, strFind, vbTextCompare) > 0 Then
                        ws3.Range("B" & entryrow).value = "Test if it works"
                        '.
                        '.
                        '.
                    End If
            Next e
        Next i

提前感谢所有提示！

Answer 1

Sub CodeForLazyPoster()

Dim rIDs As Excel.Range
Dim ID As Excel.Range
Dim lFoundRow As Long

Set rIDs = Worksheets("Sheet1").Range("a1:a10")

For Each ID In rIDs

    lFoundRow = FindRow(ID)

    If lFoundRow > 0 Then

        If FindSkill("Maths", Worksheets("Sheet2").Range("B" & lFoundRow)) Then

            '   Copy here


        End If

    End If

Next ID


End Sub

Function FindRow(strFind) As Long

FindRow = 0

On Error Resume Next

FindRow = Application.WorksheetFunction.Match( _
        strFind, Worksheets("Sheet2").Range("a1:a10"), False)

End Function

Function FindSkill(strSkill As String, rngLookIn As Excel.Range) As Boolean

Dim tmp As Integer

FindSkill = False

On Error GoTo eHandle

tmp = Application.WorksheetFunction.Match(strSkill, rngLookIn, False)

FindSkill = True

Exit Function

eHandle:


End Function

VBA在第3张工作表中从2个工作表中合并相同ID的信息

1 个答案: