如何将表2的内容匹配到表1，并根据表2第一列的内容批量生成工作簿

Qs18

试试.............

Qs18

试试........

ykcbf1100

bell19 发表于 2024-11-13 14:13
再请教一下，假如列名的位置变了，怎么一一对应表1的行名呢？

用字典，这样改写一下。

ykcbf1100

列号不固定。

1. Sub ykcbf()   '//2024.11.13
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     p = ThisWorkbook.Path & ""
   
6.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
7.     arr = Sheets("Sheet2").UsedRange
   
8.     For i = 2 To UBound(arr)
   
9.         For j = 2 To UBound(arr, 2)
   
10.             s = arr(i, 1) & "|" & arr(1, j)
    
11.             If s <> Empty Then d(s) = arr(i, j)
    
12.         Next
    
13.         sh.Copy
    
14.         Set wb = ActiveWorkbook
    
15.         With wb.Sheets(1)
    
16.             .[a1] = arr(i, 1)
    
17.             r = .Cells(Rows.Count, 1).End(3).Row
    
18.             For x = 2 To r
    
19.                 s = arr(i, 1) & "|" & .Cells(x, 1).Value
    
20.                 .Cells(x, 2) = d(s)
    
21.             Next
    
22.         End With
    
23.         wb.SaveAs p & arr(i, 1)
    
24.         wb.Close
    
25.     Next
    
26.     Set d = Nothing
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码

bell19

ykcbf1100 发表于 2024-11-13 14:42
用字典，这样改写一下。

就是用&来把两个字段合并作为唯一号，明白了，谢谢指导

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, j&, k&, dic As Object, wks As Worksheet, strFileName$
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    Set wks = Worksheets(1)
   
    ar = Worksheets(2).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        strFileName = ar(i, 1)
        For j = 2 To UBound(ar, 2)
            dic(ar(1, j)) = ar(i, j)
        Next j
        wks.Copy
        With ActiveWorkbook
            With Worksheets(1)
                br = .[A1].CurrentRegion.Value
                For k = 2 To UBound(br): br(k, 2) = dic(br(k, 1)): Next
                .[A1].CurrentRegion.Value = br
            End With
            .SaveAs ThisWorkbook.Path & "\" & strFileName
            .Close
        End With
    Next i
   
    Set dic = Nothing: Set wks = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Beep
End Sub

gwjkkkkk

请参考。。。