Question

我有2个电子表格：

main.xlsxm

enter image description here

drs.xlsx

enter image description here

我正在尝试合并两个电子表格 - 此事件将在按钮点击main.xlsx电子表格后启动（因此VBA代码将驻留在main.xlsx上）。

但是我编写代码时遇到了困难，我最初尝试使用以下Excel公式的变体，但速度非常慢。

= IFERROR（INDEX（[1.xlsx] Sheet 1中$ A：$ A，SMALL（IF（[1.xlsx] Sheet 1中$ B：$ B = $ A2，ROW（[1.xlsx] Sheet 1中！ $ B：$ B），99 ^ 99），COLUMN（A $ 1）））， “”）

我正在尝试在VBA中完成以下操作：

如果 drs.xlsx 中的列值E 等于 main.xlsx 中的列值A ：   然后在 main.xlsx 中的匹配行上   将 drs.xls 中的列值B 复制到 main.xlsx 中的列值J

如果找到第二场比赛（前提是它与第一场比赛不同）：   其中 drs.xlsx 中的列值E 等于 main.xlsx 中的列值A   将 drs.xls 中的列值B 复制到 main.xlsx 中的列值K

如果找到第三场比赛（前提是它与第一场和第二场比赛不同）：   其中 drs.xlsx 中的列值E 等于 main.xlsx 中的列值A   将 drs.xls 中的列值B 复制到 main.xlsx 中的列值L

如果第四次发生，则忽略......

我如何将其表达为VBA代码？

到目前为止，这是我的代码（准备好电子表格）：

Sub DRS_Update()
    Dim wb As Workbook

    Set wb = Workbooks.Open("C:\drs.xlsx")

    With wb.Worksheets("Sheet1")
        .AutoFilterMode = False
        With .Range("A1:D1")
            .AutoFilter Field:=1, Criteria1:="TW", Operator:=xlOr, Criteria2:="W"
            .AutoFilter Field:=3, Criteria1:="Windows 7", Operator:=xlOr, Criteria2:="Windows XP"
            .AutoFilter Field:=4, Criteria1:="Workstation-Windows"
        End With
    End With
End Sub

Answer 1

尝试以下代码。我已经详细评论了它，但如果你有一些问题，请随时在评论中提问：）

Sub test()
    Dim wb As Workbook
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim user As Range

    Dim lastrowDRS As Long, lastrowMAIN As Long
    Dim rng As Range, res As Range
    Dim k As Byte
    Dim fAddr As String

    Application.ScreenUpdating = False

    'specify sheet name for main workbook
    Set sh1 = ThisWorkbook.Worksheets("Sheet1")

    'if drs is already opened
    'Set wb = Workbooks("drs.xlsx")
    'if drs not already opened
    Set wb = Workbooks.Open("C:\drs.xlsx")

    'specify sheet name for drs workbook
    Set sh2 = wb.Worksheets("Sheet1")


    With sh1
        'find last row on column A in main wb
        lastrowMAIN = .Cells(.Rows.Count, "A").End(xlUp).Row

        'clear prev data in columns J:L
        .Range("J1:L" & lastrowMAIN).ClearContents
    End With

    With sh2
        .AutoFilterMode = False
        'find last row on column A in drs wb
        lastrowDRS = .Cells(.Rows.Count, "A").End(xlUp).Row

        'apply filter
        With .Range("A1:D1")
            .AutoFilter Field:=1, Criteria1:="TW", Operator:=xlOr, Criteria2:="W"
            .AutoFilter Field:=3, Criteria1:="Windows 7", Operator:=xlOr, Criteria2:="Windows XP"
            .AutoFilter Field:=4, Criteria1:="Workstation-Windows"
        End With

        On Error Resume Next
        'get only visible rows in column E
        Set rng = .Range("E1:E" & lastrowDRS).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0

        'loop throught each user in main wb
        For Each user In sh1.Range("A1:A" & lastrowMAIN)
            'counter for finding entries
            k = 0
            'find first match
            Set res = rng.Find(what:=user.Value, MatchCase:=False)
            If Not res Is Nothing Then
                'remember address of first match
                fAddr = res.Address
                Do
                    'user.Offset(, 9 + k) gives you column J for k=0, K for k=1, L for k=2
                    user.Offset(, 9 + k).Value = res.Offset(, -3).Value
                    'increment k
                    k = k + 1
                    'find next match
                    Set res = rng.FindNext(res)
                    'if nothing found exit stop searcing entries for current user
                    If res Is Nothing Then Exit Do
                'if we already found 3 mathes, then stop search for current user
                Loop While fAddr <> res.Address And k < 3
            End If
        Next user
    End With

    'close drs wb without saving changes
    wb.Close saveChanges:=False
    Set wb = Nothing

    Application.ScreenUpdating = True
End Sub

单击按钮后合并两个电子表格

1 个答案: