遍历工作表固定位置添补数据

司马迁的硬盘

首先感谢老师们帮忙之中的帮忙！


需求：遍历需要填凑数据的表（表名11），假如查到该表J3单元格的姓名在“批量填充”表里存在，则填充到11表指定的单元格位置，
         比方：11表sheet2的J3单元格为张三，则sheet2的A1单元格填充3，B5单元格填充16，D3单元格填充29
                   11表sheet3的J3单元格为李四，则sheet3的A1单元格填充8，B5单元格填充18，D3单元格填充38
                   也就是“批量填充”表的B1：D1单元格是指示数据要填充的目标工作簿单元格的位置。
         遍历的时候，对能查到的人（也就是实行了填充的人）在“批量填充”表名字相应单元格标志颜色，以便知道哪些人还没有实行填充。
         宏在“批量填充”表，对11表进行填充。

再次感谢老师的帮助！多谢！
11.rar

风的呢喃

参与一下，仅供参考。。。
批量填充 2026-05-12 16-45-40.zip

小辣鸡

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    tm = Timer
    Dim wb As Workbook, sht As Worksheet, sh As Worksheet
    Set wb = ThisWorkbook
    file = wb.Path & "\11.xlsx"
    Set sht = wb.Sheets("Sheet1")
    arr = sht.[a1].CurrentRegion
    sht.Range(sht.[a3], sht.Cells(UBound(arr), 1)).Interior.Color = xlNone
    Set d = CreateObject("scripting.dictionary")
    For i = 3 To UBound(arr)
        d(arr(i, 1)) = i
    Next
    With Workbooks.Open(file, 0)
        For Each sh In .Sheets
            s = sh.[j3]
            If d.exists(s) Then
                sht.Cells(d(s), 1).Interior.Color = vbGreen
                For j = 1 To 3
                    sh.Range(arr(1, 1 + j)) = arr(d(s), j + 1)
                Next
            End If
        Next
        .Save
        '        .Close
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "共耗时：" & Format(Timer - tm, "0.0000") & " 秒！！！", 64
    Set d = Nothing
End Sub

金陵镖师

Sub 遍历填充()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Dim rn As Range
LJ = ThisWorkbook.Path & "\"
f = Dir(LJ & "11.xls*")
If f = "" Then MsgBox "找不到11文件！": End
With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox &quot;数据源工作表为空，请先导入数据！&quot;: End
    .Range(&quot;e2&quot;).Resize(r - 1, 1).Interior.ColorIndex = 0
    ar = .Range(&quot;a1&quot;).Resize(r, 5)
    For i = 2 To UBound(ar)
        s = ar(i, 1)
        If s  &quot;&quot; Then
            d(s) = i
        End If
    Next i
    Set wb = Workbooks.Open(LJ & f, 0)
    For Each sh In wb.Worksheets
        xm = sh.[j3].Value
        xh = d(xm)
        If xh  &quot;&quot; Then
            If rn Is Nothing Then
                Set rn = .Cells(xh, 1)
            Else
                Set rn = Union(rn, .Cells(xh, 1))
            End If
            sh.[a1] = ar(xh, 2)
            sh.[b5] = ar(xh, 3)
            sh.[d3] = ar(xh, 4)
        End If
    Next sh
    If Not rn Is Nothing Then rn.Interior.ColorIndex = 3
    wb.Close True
End With
Application.ScreenUpdating = True
MsgBox &quot;ok!&quot;
End Sub

联通刘会军

11.rar

陈晓梅

批量填充.rar

易赫斋风水社

• Sub test()
  
• On Error Resume Next
  
• Set d = CreateObject(&quot;scripting.dictionary&quot;)
  
• ar = ActiveSheet.[a1].CurrentRegion.Resize(, 5)
  
• For i = 2 To UBound(ar)
  
•     d(ar(i, 1)) = i
  
• Next
  
• Application.ScreenUpdating = False
  
• Set wb = Workbooks.Open(ThisWorkbook.Path & &quot;\11.xlsx&quot;)
  
• For Each sh In wb.Sheets
  
•     s = sh.[j3].Value
  
•     If d.exists(s) Then
  
•         sh.[a1] = ar(d(s), 2)
  
•         sh.[b5] = ar(d(s), 3)
  
•         sh.[d7] = ar(d(s), 4)
  
•         ar(d(s), 5) = &quot;已填充&quot;
  
•     End If
  
• Next
  
• wb.Close True
  
• ActiveSheet.[a1].CurrentRegion.Resize(, 5) = ar
  
• Application.ScreenUpdating = TrueMsgBox &quot;ok!&quot;End Sub
  

五彩糖纸

参与一下。。。

11.zip

有福之州

• Sub ykcbf()  '//2026.5.12
  
•     Application.ScreenUpdating = False
  
•     p = ThisWorkbook.Path & Application.PathSeparator
  
•     f = p & &quot;11.xlsx&quot;
  
•     ReDim brr(1 To 10 ^ 4, 1 To 4)
  
•     Set wb = Workbooks.Open(f, 0, True, , False)
  
•     For Each sht In wb.Sheets
  
•         If sht.[j3].Value  Empty Then
  
•             m = m + 1
  
•             With sht
  
•                 brr(m, 1) = .[j3].Value
  
•                 brr(m, 2) = .[a1].Value
  
•                 brr(m, 3) = .[b5].Value
  
•                 brr(m, 4) = .[d7].Value
  
•             End With
  
•         End If
  
•     Next
  
•     wb.Close False
  
•     With Sheets(&quot;Sheet1&quot;)
  
•         .UsedRange.Offset(2).ClearContents
  
•         .[a3].Resize(m, 4) = brr
  
•         .[a3].Resize(m, 4).Borders.LineStyle = 1
  
•     End With
  
•     Application.ScreenUpdating = True
  
•     MsgBox &quot;OK！&quot;, vbInformation
  
• End Sub
  

郭姐

Option Explicit
Sub test()
    Dim ar, i&, j&, strFileName$, strPath$, wks As Worksheet
   
    Application.ScreenUpdating = False
   
    strPath = ThisWorkbook.Path & &quot;\&quot;
    strFileName = strPath & &quot;11.xlsx&quot;
    If Dir(strFileName) = &quot;&quot; Then
        Application.ScreenUpdating = True
        MsgBox &quot;目标文件不存在&quot;, vbCritical: Exit Sub
    End If
   
    ar = Range(&quot;A1&quot;).CurrentRegion.Value
    With Workbooks.Open(strFileName)
        For i = 3 To UBound(ar)
            For Each wks In .Worksheets
                If wks.Range(&quot;J3&quot;).Value = ar(i, 1) Then
                    With wks
                        For j = 2 To UBound(ar, 2)
                            .Range(ar(1, j)).Interior.Color = vbRed
                            .Range(ar(1, j)).Value = ar(i, j)
                        Next j
                    End With
                End If
            Next
        Next i
        .Close True
    End With
   
    Application.ScreenUpdating = True
    Beep
End Sub