Question

Hello目前，我有能够在两张纸内运行并进行匹配的代码，并在两个ID匹配时将信息从“工作表2”复制粘贴到“工作表1”。

但是，每张纸上有超过100000行。因此，当我运行代码时，它一直在运行。我尝试了不到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

非常感谢任何帮助。谢谢！:)

Answer 1

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

Answer 2

选项1：优化VBA：

ScreenUpdating = False
关闭AutomaticUpdating
等

查看更多提示here。

选项2：MS查询

如何快速查询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_X替换为正确的列标题。

随意使用我的SQL AddIn或转到Excel并选择 DATA - ＆gt; 来自其他来源 - ＆gt; 来自Microsoft Query < / KBD>

复制具有匹配ID的粘贴信息，该ID在工作簿中的每个工作表中具有超过100000行

2 个答案:

选项1：优化VBA：

选项2：MS查询