复制工作簿中每个工作表中具有超过100000行的匹配ID的粘贴信息
你好目前我有能够运行的代码，并且在两张表格内匹配，当两个ID匹配时，将信息从“表格2”复制到“表格1”。
但是，我在每张纸上有超过100000行。 因此，当我运行代码时，它一直在运行。 我尝试了less于1000行的代码，并运行3-4分钟后，它的作品。 但是，当我试图运行100000行，它保持运行。
我希望有人可以帮助我改善我的代码，让它运行超过100000行。 这是我有的代码：
Sub AAA() Dim tracker As Worksheet Dim master As Worksheet Dim cell As Range Dim cellFound As Range Dim OutPut As Integer Set tracker = Workbooks("test.xlsm").Sheets("Sheet1") Set master = Workbooks("test.xlsm").Sheets("Sheet2") For Each cell In master.Range("A2:A100000") Set cellFound = tracker.Range("A5:A43000").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole) If Not cellFound Is Nothing Then cellFound.Offset(ColumnOffset:=1).Value2 = cell.Offset(ColumnOffset:=2).Value2 Else End If Set cellFound = Nothing Debug.Print cell.Address Next OutPut = MsgBox("Update over!", vbOKOnly, "Update Status") End Sub 任何帮助将非常感激。 谢谢！：）
Sub compare_sheet1_with_sheet2() For i = 1 To 100000 For j = 1 To 100000 If Worksheets("sheet1").Range("A" & i).Value = Worksheets("sheet2").Range("A" & j).Value Then Worksheets("sheet2").Range("A" & i & ":P" & i).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 .PatternTintAndShade = 0 End With End If Next j Next i end sub
选项1：优化VBA：
- ScreenUpdating = False
- closuresAutomaticUpdating
- 等等
在这里查看更多提示。
选项2：MS Query
如何快速MS查询？
SELECT S1.COLUMN_A, Iif(S2.COLUMN_A IS NULL, S1.COLUMN_B, S2.COLUMN_C) FROM [Sheet1$] as S1 LEFT JOIN [Sheet2$] as S2 ON S1.COLUMN_A = S2.COLUMN_A
将COLUMN_Xreplace为正确的列标题。
随意使用我的SQL AddIn或转到Excel并select数据 – > 从其他来源 – > 从Microsoft Query
提到的AnalystCave.com插件基本上是一个创buildQuerytables的向导，这是一个标准的Excelfunction。 一旦创build，QueryTable将与工作簿一起保存，不再需要插件。
Excel还为用户提供了一种创build这些QueryTable的方法（不使用VBA），但是这个过程是可怕的。
刚刚使用插件，我会推荐使用它，并build议不要编写自己的VBA代码来为自己创buildQueryTable（因为这很耗时）。 但是，如果你确实想用VBA创build它们，这里有一些代码可以让你开始。
请注意，另一种方法是使用MS PowerQuery，但是对于简单的东西，插件比电源查询要容易和快捷（微软做得很好，但插件作者赢得了这一轮）
Sub CreateAQueryConnection() Dim wks As Worksheet Dim MyConnection As String Dim qt As QueryTable Set wks = ActiveSheet 'Clear worksheet of old QueryTables For Each qt In wks.QueryTables qt.Delete Next qt ' Build a connection string using http://www.connectionstrings.com/excel/ ' (The one below is overkill!) MyConnection = Join(Array( _ "OLEDB;Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=C:\Users\Harvey\OneDrive\My Study\Excel Study\SQL Addin1.xlsx;Mode=S" _ , "hare Deny Write;Extended Properties=""Excel 12.0 Xml;HDR=YES"";Jet OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDB:E" _ , "ngine Type=35;Jet OLEDB:Database Locking Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk Transactions=1;Jet OLE" _ , "DB:New Database Password="""";Jet OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OLEDB:Don't Copy Locale " _ , "on Compact=False;Jet OLEDB:Compact Without Replica Repair=False;Jet OLEDB:SFP=False;Jet OLEDB:Support Complex Data=False;Jet OLE" _ , "DB:Bypass UserInfo Validation=False;Jet OLEDB:Limited DB Caching=False;Jet OLEDB:Bypass ChoiceField Validation=False" _ ), "") 'Check if querytable exists If wks.QueryTables.Count > 0 Then Set qt = wks.QueryTables("qt" & wks.codename) Else Set qt = wks.QueryTables.Add(Connection:=MyConnection, Destination:=wks.Cells(1, 1)) End If With qt .CommandType = xlCmdSql ' Yuo will need to chnage the sql that you use .CommandText = Array("SELECT T1.* FROM [Sheet1$] AS T1") ' you could set the name here - it's done already ' .Name = "" .FieldNames = True .RowNumbers = False .AdjustColumnWidth = True .FillAdjacentFormulas = True .PreserveFormatting = True .PreserveColumnInfo = False .SavePassword = False .SaveData = True .RefreshOnFileOpen = True .BackgroundQuery = True .RefreshStyle = xlOverwriteCells .RefreshPeriod = 60 .Refresh BackgroundQuery:=False End With ' Set ExecuteSQL = qt.ResultRange Debug.Print qt.ResultRange.Address End Sub