Excel VBA宏需运行两次才可获取完整数据的解决咨询

问题说明 #

我编写的Excel VBA宏中，「从wb2.Sh3导入数据」的逻辑运行正常，该部分会将数据写入Sh1工作表的B列；而「从wb.Sh2导入数据」的逻辑需要依赖Sh1的B列数据完成匹配导入。但首次运行宏时，第二部分逻辑无法读取到第一部分刚写入的B列数据，必须运行第二次才能完成全部数据导入，请问如何修改代码实现单次运行完成所有操作？

原代码 #

Option Explicit ' at the top of each module
Sub Autofill()

Dim wb As Workbook: Set wb = Excel.Workbooks("testing (version 2).xlsm") ' workbook containing this code
Dim wb2 As Excel.Workbook

On Error Resume Next
Set wb2 = Excel.Workbooks("Job Nos.xlsx")

If Err <> 0 Then
    On Error GoTo 0
    Workbooks.Open ("C:\Users\Todd\Desktop\Job Nos.xlsx")
    Set wb2 = Excel.Workbooks("Job Nos.xlsx")
    Windows("testing (version 2).xlsm").Activate
End If

Dim Sh1 As Worksheet: Set Sh1 = wb.Sheets("Certificates") '<-The sheet that you test B for TRUE
Dim Sh2 As Worksheet: Set Sh2 = wb.Sheets("Codes") '<- The sheet for the vlookup range
Dim Sh3 As Worksheet: Set Sh3 = wb2.Sheets("Jobs")
Dim MyVariable As Variant
Dim rng As Range
Dim slrg As Range: Set slrg = Sh2.Range("A2", Sh2.Cells(Sh2.Rows.Count, "A").End(xlUp))
Dim jslrg As Range: Set jslrg = Sh3.Range("A2", Sh3.Cells(Sh3.Rows.Count, "A").End(xlUp))
Dim srg As Range: Set srg = slrg.EntireRow
Dim jsrg As Range: Set jsrg = jslrg.EntireRow
Dim drg As Range: Set drg = Sh1.Range("B2", Sh1.Cells(Sh1.Rows.Count, "B").End(xlUp))
Dim jdrg As Range: Set jdrg = Sh1.Range("I2", Sh1.Cells(Sh1.Rows.Count, "I").End(xlUp))
    
    
    ' Import data from wb2.Sh3.
    Dim bcell As Range, aRow As Variant
    For Each bcell In jdrg.Cells
        With bcell.EntireRow
            If bcell.Value > 0 And .Columns("E").Value = 0 Then
                aRow = Application.Match(bcell.Value, jslrg, 0)
                If IsNumeric(aRow) Then
                    .Columns("G").Value = jsrg.Rows(aRow).Columns("B").Value
                    .Columns("H").Value = jsrg.Rows(aRow).Columns("C").Value
                    .Columns("B").Value = jsrg.Rows(aRow).Columns("D").Value
                Else
                    .Columns("G").Value = ""
                    .Columns("H").Value = ""
                    .Columns("B").Value = ""
                End If
            End If
        End With
    Next bcell

' ***It completes the above section which enters data that the below needs to be able to complete the below but macro needs to be run a second time for that to run***

    ' Import data from wb.Sh2.
    Dim dcell As Range, sRow As Variant
    For Each dcell In drg.Cells
        With dcell.EntireRow
            If dcell.Value > 0 And .Columns("E").Value = 0 Then
                sRow = Application.Match(dcell.Value, slrg, 0)
                If IsNumeric(sRow) Then
                    .Columns("E:F").Value = srg.Rows(sRow).Columns("D:E").Value
                    .Columns("J:S").Value = srg.Rows(sRow).Columns("I:R").Value
                Else
                    .Columns("E:F").Value = ""
                    .Columns("J:S").Value = ""
                End If
                .Columns("T:DT").Value = Sh2.Range("G19:DG19").Value
            End If
        End With
    Next dcell

Dim LR_B As Single
LR_B = Sh1.Range("B" & Rows.Count).End(xlUp).Row
Dim LR_A As Single
LR_A = Sh1.Range("A" & Rows.Count).End(xlUp).Row

    Sh1.Range("A" & LR_A).Select
    If (LR_B - LR_A) > 0 Then
        Selection.Autofill Destination:=Sh1.Range("A" & LR_A & ":A" & LR_B)
    End If
    Sh1.Range("A" & LR_B).Select
End Sub

问题根源 #

代码开头提前定义了drg变量（指向Sh1工作表B列的现有数据范围），此时B列还未被第一部分逻辑更新。当第二部分逻辑循环drg时，遍历的是更新前的B列数据范围，自然无法读取到第一部分刚写入的依赖数据。

修改方案 #

将drg的定义移至第一部分数据导入完成之后，确保第二部分逻辑使用的是更新后的B列数据范围。同时移除开头冗余的drg定义。

修改后的代码 #

Option Explicit ' at the top of each module
Sub Autofill()

Dim wb As Workbook: Set wb = Excel.Workbooks("testing (version 2).xlsm") ' workbook containing this code
Dim wb2 As Excel.Workbook

On Error Resume Next
Set wb2 = Excel.Workbooks("Job Nos.xlsx")

If Err <> 0 Then
    On Error GoTo 0
    Workbooks.Open ("C:\Users\Todd\Desktop\Job Nos.xlsx")
    Set wb2 = Excel.Workbooks("Job Nos.xlsx")
    Windows("testing (version 2).xlsm").Activate
End If

Dim Sh1 As Worksheet: Set Sh1 = wb.Sheets("Certificates") '<-The sheet that you test B for TRUE
Dim Sh2 As Worksheet: Set Sh2 = wb.Sheets("Codes") '<- The sheet for the vlookup range
Dim Sh3 As Worksheet: Set Sh3 = wb2.Sheets("Jobs")
Dim MyVariable As Variant
Dim rng As Range
Dim slrg As Range: Set slrg = Sh2.Range("A2", Sh2.Cells(Sh2.Rows.Count, "A").End(xlUp))
Dim jslrg As Range: Set jslrg = Sh3.Range("A2", Sh3.Cells(Sh3.Rows.Count, "A").End(xlUp))
Dim srg As Range: Set srg = slrg.EntireRow
Dim jsrg As Range: Set jsrg = jslrg.EntireRow
' 移除开头的drg定义，移至第一部分导入完成后
Dim jdrg As Range: Set jdrg = Sh1.Range("I2", Sh1.Cells(Sh1.Rows.Count, "I").End(xlUp))
    
    
    ' Import data from wb2.Sh3.
    Dim bcell As Range, aRow As Variant
    For Each bcell In jdrg.Cells
        With bcell.EntireRow
            If bcell.Value > 0 And .Columns("E").Value = 0 Then
                aRow = Application.Match(bcell.Value, jslrg, 0)
                If IsNumeric(aRow) Then
                    .Columns("G").Value = jsrg.Rows(aRow).Columns("B").Value
                    .Columns("H").Value = jsrg.Rows(aRow).Columns("C").Value
                    .Columns("B").Value = jsrg.Rows(aRow).Columns("D").Value
                Else
                    .Columns("G").Value = ""
                    .Columns("H").Value = ""
                    .Columns("B").Value = ""
                End If
            End If
        End With
    Next bcell

' 第一部分数据导入完成后，重新定义drg，获取更新后的B列范围
Dim drg As Range: Set drg = Sh1.Range("B2", Sh1.Cells(Sh1.Rows.Count, "B").End(xlUp))

    ' Import data from wb.Sh2.
    Dim dcell As Range, sRow As Variant
    For Each dcell In drg.Cells
        With dcell.EntireRow
            If dcell.Value > 0 And .Columns("E").Value = 0 Then
                sRow = Application.Match(dcell.Value, slrg, 0)
                If IsNumeric(sRow) Then
                    .Columns("E:F").Value = srg.Rows(sRow).Columns("D:E").Value
                    .Columns("J:S").Value = srg.Rows(sRow).Columns("I:R").Value
                Else
                    .Columns("E:F").Value = ""
                    .Columns("J:S").Value = ""
                End If
                .Columns("T:DT").Value = Sh2.Range("G19:DG19").Value
            End If
        End With
    Next dcell

Dim LR_B As Single
LR_B = Sh1.Range("B" & Rows.Count).End(xlUp).Row
Dim LR_A As Single
LR_A = Sh1.Range("A" & Rows.Count).End(xlUp).Row

    Sh1.Range("A" & LR_A).Select
    If (LR_B - LR_A) > 0 Then
        Selection.Autofill Destination:=Sh1.Range("A" & LR_A & ":A" & LR_B)
    End If
    Sh1.Range("A" & LR_B).Select
End Sub

关键修改点 #

• 移除代码开头的Dim drg As Range: Set drg = ...定义
• 在第一部分数据导入完成后，新增Dim drg As Range: Set drg = ...，此时获取的是更新后的B列数据范围
• 第二部分逻辑循环的drg即为第一部分写入数据后的最新范围，能正确读取依赖数据完成匹配导入

内容的提问来源于stack exchange，提问作者Todd Harris