Question

我想整合两个excel文件，两者都有不同的布局。这两个文件之间唯一的共同列是＆＃34; name＆＃34;和＆＃34;邮政编码＆＃34;。文件1是＆＃34;基本文件＆＃34;，文件2包含我想要集成到文件1中的附加信息。

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

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

以下代码有效，但速度太慢。整合一行需要大约两分钟。您对如何提高性能有任何建议吗？

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

你正在创建一个全新的Excel实例来实现这一目标会减慢你的速度很多 - 每个对第二个实例的调用都必须在两个进程（新实例和运行代码的进程） - 由于下面的测试方法显示，需要花费大量开销：

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实例，并在找到匹配后立即退出循环：

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

编译但未经测试。

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

1 个答案: