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

bell19

表1的行名与表2的列名相同，求助如何使用VBA把表2的内容匹配到表1对应行名右侧的单元格，




并根据表2的科室名称放到表头合并单元格（科室名称），完成后批量生成以科室名称命名的工作簿

蓝桥玄霜

数据的例子：

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

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

复制代码

bell19

感谢大佬们的帮助

usedrange

看看是不是你想要的。。。。。

cjc209

这种函数就简单搞定了=XLOOKUP($A$1,Sheet2!$A$2:$A$9,XLOOKUP($A2,Sheet2!$B$1:$F$1,Sheet2!$B$2:$F$9))

bell19

cjc209 发表于 2024-11-13 12:27
这种函数就简单搞定了=XLOOKUP($A$1,Sheet2!$A$2:$A$9,XLOOKUP($A2,Sheet2!$B$1:$F$1,Sheet2!$B$2:$F$9))

想批量生成对应科室啊，不是简单一个表

bell19

ykcbf1100 发表于 2024-11-13 09:57
参与一下。。。

再请教一下，假如列名的位置变了，怎么一一对应表1的行名呢？

Qs18

1. Sub qs()
   
2. Application.ScreenUpdating = False: Application.DisplayAlerts = False
   
3. Dim arr, i, dic, sht As Worksheet, wb As Workbook
   
4. Set sht = Sheet1
   
5. p = ThisWorkbook.Path & ""
   
6. arr = Sheet2.Range("a1").CurrentRegion.Value
   
7. brr = Sheet1.Range("a1").CurrentRegion.Value
   
8. For i = 2 To UBound(arr)
   
9.     brr(1, 1) = arr(i, 1)
   
10.     For r = 2 To UBound(brr)
    
11.        For j = 2 To UBound(arr, 2)
    
12.             If brr(r, 1) = arr(1, j) Then
    
13.                 brr(r, 2) = arr(i, j)
    
14.                 Exit For
    
15.             End If
    
16.        Next j
    
17.     Next r
    
18.     Sheet1.Range("a1").Resize(UBound(brr), 2) = brr
    
19.    sht.Copy
    
20.    Set wb = ActiveWorkbook
    
21.    wb.SaveAs p & brr(1, 1) & ".xlsx"
    
22.    wb.Close
    
23. Next i
    
24. Set sht = Nothing: Set wb = Nothing
    
25. Application.ScreenUpdating = True: Application.DisplayAlerts = True
    
26. End Sub
    

复制代码