根据多个条件合并两个Excel工作簿

我想合并两个不同的布局的Excel文件。 两个文件之间唯一的共同列是“名称”和“邮政编码”。 文件1是“基本文件”，文件2包含我想要集成到文件1中的附加信息。

当相应行的名称和邮政编码相同时，只能将附加信息（地址，国家，字段7和字段8）复制到基本文件中。 基本文件有多个工作表，相应的行可以在任何工作表中。

两个excel文件都非常大（> 60000行，5列）。 代码应该从文件2中获取第一个条目，并在文件1中search相应的条目。如果find，则附加信息将被复制到文件1中。然后（或者如果找不到相应的条目）重新运行该过程，时间与文件2中的第二个条目 – 只要文件2中的所有条目已合并到文件1中。

下面的代码工作，但是太慢了。 花了大约两分钟来巩固一个单一的行。 你有什么build议如何提高性能？

Sub merging_two_excel_files() ' Dim data_path As String Dim filename_base As String Dim filename_addon As String Dim xlApp As Excel.Application Dim xlBook_base As Workbook Dim xlBook_addon As Workbook data_path = "..." filename_base = "file1" filename_addon = "file2" Set xlApp = CreateObject("Excel.Application") Set xlBook_base = xlApp.Workbooks.Open(data_path & filename_base) Set xlBook_addon = xlApp.Workbooks.Open(data_path & filename_addon) screenUpdateState = xlApp.ScreenUpdating statusBarState = xlApp.DisplayStatusBar calcState = xlApp.Calculation eventsState = xlApp.EnableEvents xlApp.ScreenUpdating = False xlApp.DisplayStatusBar = False xlApp.Calculation = xlCalculationManual xlApp.EnableEvents = False With xlBook_addon.Worksheets(1) Dim number_of_rows_addon As Long number_of_rows_addon = .Range("B1", .Range("B" & .Rows.Count).End(xlUp)).Rows.Count End With For k = 2 To number_of_rows_addon Step 1 Dim name_addon As String Dim postalcode_addon As String Dim address_addon As String Dim country_addon As String Dim field7_addon As String Dim field8_addon As String name_addon = xlBook_addon.Worksheets(1).Cells(k, 2).Value postalcode_addon = xlBook_addon.Worksheets(1).Cells(k, 4).Value address_addon = xlBook_addon.Worksheets(1).Cells(k, 3).Value country_addon = xlBook_addon.Worksheets(1).Cells(k, 6).Value field7_addon = xlBook_addon.Worksheets(1).Cells(k, 7).Value field8_addon = xlBook_addon.Worksheets(1).Cells(k, 8).Value Dim number_of_worksheets_base As Long number_of_worksheets_base = xlBook_base.Worksheets.Count For d = 1 To number_of_worksheets_base Step 1 With xlBook_base.Worksheets(d) Dim number_of_rows_base As Long number_of_rows_base = .Range("B1", .Range("B" & .Rows.Count).End(xlUp)).Rows.Count For c = 2 To number_of_rows_base Step 1 If name_addon = .Cells(c, 6).Value And postalcode_addon = .Cells(c, 1).Value Then .Cells(c, 7).Value = address_addon .Cells(c, 8).Value = country_addon .Cells(c, 9).Value = field7_addon .Cells(c, 10).Value = field8_addon Else End If Next c End With Next d Next k xlApp.ScreenUpdating = screenUpdateState xlApp.DisplayStatusBar = statusBarState xlApp.Calculation = calcState xlApp.EnableEvents = eventsState Application.DisplayAlerts = False xlBook_base.Close SaveChanges:=True Application.DisplayAlerts = True xlBook_addon.Close SaveChanges:=False xlApp.Application.Quit Set xlApp = Nothing MsgBox "Done!" End Sub 

Answer 1

事实上，你正在创build一个全新的Excel实例来做这件事会让你减慢很多 – 对第二个实例的每一个调用都必须在两个进程之间传递（新实例和那个在哪里你的代码正在运行） – 这需要大量的开销，下面的testing方法显示：

 Sub TEST() Dim xlapp As Excel.Application, wb As Excel.Workbook Dim c As Range, v, r As Long, t Set xlapp = CreateObject("excel.application") xlapp.Visible = True 'using another Excel instance t = Timer Set wb = xlapp.Workbooks.Add() For r = 1 To 10000 v = wb.Sheets(1).Cells(r, 1).Value Next r Debug.Print Timer - t '~ 20secs <<<<<<<<< xlapp.Quit 'using the current instance t = Timer Set wb = ThisWorkbook For r = 1 To 10000 v = wb.Sheets(1).Cells(r, 1).Value Next r Debug.Print Timer - t '~0.08 secs <<<<<<<< End Sub 

使用第二个实例要慢得多。

没有第二个Excel实例，一旦find匹配项，就退出循环：

 Sub merging_two_excel_files() Const data_path As String = "..." Const filename_base As String = "file1" Const filename_addon As String = "file2" Dim xlBook_base As Workbook Dim xlBook_addon As Workbook, shtAddon As Worksheet Dim last_row_addon As Long, name_addon As String Dim postalcode_addon As String, shtBase As Worksheet Dim last_row_base As Long, k As Long, c As Long, rw As Range Set xlBook_base = Workbooks.Open(data_path & filename_base) Set xlBook_addon = Workbooks.Open(data_path & filename_addon) Set shtAddon = xlBook_addon.Worksheets(1) last_row_addon = shtAddon.Cells(shtAddon.Rows.Count, 2).End(xlUp).Row For k = 2 To last_row_addon Set rw = shtAddon.Rows(k) name_addon = rw.Cells(2).Value postalcode_addon = rw.Cells(4).Value For Each shtBase In xlBook_base.Worksheets With shtBase last_row_base = .Cells(.Rows.Count, 2).End(xlUp).Row For c = 2 To last_row_base If name_addon = .Cells(c, 6).Value And _ postalcode_addon = .Cells(c, 1).Value Then .Cells(c, 7).Value = rw.Cells(3).Value .Cells(c, 8).Value = rw.Cells(6).Value .Cells(c, 9).Value = rw.Cells(7).Value .Cells(c, 10).Value = rw.Cells(8).Value GoTo found '### exit loop after finding the matching row.... End If Next c End With Next shtBase found: Next k Application.DisplayAlerts = False xlBook_base.Close SaveChanges:=True Application.DisplayAlerts = True xlBook_addon.Close SaveChanges:=False MsgBox "Done!" End Sub 

编译但未经testing。