一個按鈕後，合併兩個電子表格點擊

Question

我有2個電子表格：

main.xlsxm

drs.xlsx

我試圖合併這兩個電子表格 - 此事件將在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 ]工作表Sheet1 $ B：$ B），99^99），COLUMN（A $ 1）））， 「」）

我試圖完成在VBA如下：

如果列值E in drs.xlsx等於列值A in main.xlsx： 然後在匹配行main.xlsx 複印列值B在drs.xls到列值J在main.xlsx

如果第二個發現匹配（只要它是不一樣的第一個匹配）： 凡列值E在drs.xlsx等於列值A在main.xlsx 複印列值B在drs.xls到列值K在main.xlsx

如果三分之一發現匹配（只要它是不一樣的，第一和第二匹配） ： 凡列值E在drs.xlsx等於列值A在main.xlsx 複製列值Bdrs.xls到列值L在main.xlsx

如果它發生了第四次則忽略......

我怎麼會說出這樣的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