VBA两表合并

hjd528 · 发表于 2024-1-21 10:55

本帖最后由 hjd528 于 2024-1-22 15:41 编辑

如果Sheet1和Sheet2两个表的第2列姓名和第3列班级相同时，则将两表数据合并到Sheet3中（模拟表中只有一个班级，实际上有多个班级）。表中代码借用了https://club.excelhome.net/thread-1201390-1-1.html二楼linyh1742595842老师的代码，但运行时有卡顿，4楼hlly888老师的代码运行快一些，但无法修改。请各位大侠帮忙解决。谢谢！

截图.png

两表合并.rar (12.65 KB, 下载次数: 12)

ykcbf1100 · 发表于 2024-1-21 11:29

参与一下。。。

Sub ykcbf() '//2024.1.21
Dim arr, d, sht
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
Set Sh = ThisWorkbook.Sheets("合并")
For Each sht In Sheets
If sht.Name <> Sh.Name Then
With sht
r = .Cells(.Rows.Count, "a").End(xlUp).Row
c = .UsedRange.Columns.Count
arr = .[a1].Resize(r, c)
End With
For j = 1 To UBound(arr, 2)
s = arr(1, j)
d1(s) = ""
Next
For i = 2 To UBound(arr)
For j = 4 To UBound(arr, 2)
s = arr(i, 2) & "|" & arr(i, 3)
If Not d.Exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
d(s)(arr(1, j)) = arr(i, j)
Next
Next
End If
Next
ReDim brr(1 To d.Count, 1 To 3)
For Each k In d.keys
m = m + 1
brr(m, 1) = m
brr(m, 2) = Split(k, "|")(0)
brr(m, 3) = Split(k, "|")(1)
Next
With Sh
.UsedRange.Clear
.[a1].Resize(1, d1.Count) = d1.keys
.[a2].Resize(m, 3) = brr
arr = .[a1].Resize(m + 1, d1.Count)
.[a1].Resize(m + 1, d1.Count).Borders.LineStyle = 1
For i = 2 To UBound(arr)
For j = 4 To UBound(arr, 2)
s = arr(i, 2) & "|" & arr(i, 3)
If d.Exists(s) Then
arr(i, j) = d(s)(arr(1, j))
End If
Next
With .[a1].Resize(m + 1, d1.Count)
.Value = arr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next
End With
Set d = Nothing
Set d1 = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-1-21 11:31

本帖最后由 ykcbf1100 于 2024-1-21 12:20 编辑

附件供参考。。。

hjd528 · 发表于 2024-1-21 12:13

本帖最后由 hjd528 于 2024-1-21 12:20 编辑

ykcbf1100 发表于 2024-1-21 11:31
附件供参考。。。

谢谢老师的帮助，但合并表少了三科的成绩。还得麻烦老师抽空改一下。

QQ截图20240121121203.png

ykcbf1100 · 发表于 2024-1-21 12:19

hjd528 发表于 2024-1-21 12:13
老师，合并表少了三科的成绩。还得麻烦你改一改。

改好了。。。

cjc209 · 发表于 2024-1-21 12:22

如果班级相同学生还是那些学生也就是不相同的学生名都在就可以这样自定义jsa 宏代码
function test(){
var arr=maxArray_Z("Sheet2!b1:k1").map2d_Z(x=>Number(String(x).replace(/\D+/g,"")),"f1");
var arr1=zip_Z([maxArray_Z("Sheet1!a1:k1"),sortByCols_Z(arr,"f1",1).deleteCols_Z("f1,f2")])
arr1.toRange_Z("合并!t1").加边框().自动行高列宽()
}

hjd528 · 发表于 2024-1-21 12:26

本帖最后由 hjd528 于 2024-1-21 16:08 编辑

ykcbf1100 发表于 2024-1-21 12:19
改好了。。。

谢谢老师！Sheet1和Sheet2的学科任意互换或增加，无需修改代码，都可以将两表合并，适合V小白使用。

zjdh · 发表于 2024-1-21 12:34

本帖最后由 zjdh 于 2024-1-21 13:49 编辑

其实将原来的的代码改成数组处理，运行速度是很快的！

两表合并2.rar (19.57 KB, 下载次数: 17)

excel玉米 · 发表于 2024-1-21 13:11

本帖最后由 excel玉米于 2024-1-21 13:45 编辑

以此附件为准！

hjd528 · 发表于 2024-1-21 15:39

cjc209 发表于 2024-1-21 12:22
如果班级相同学生还是那些学生也就是不相同的学生名都在就可以这样自定义jsa 宏代码
function test(){
...

谢谢回帖！电脑没有安装WPS。

		自动登录	找回密码
密码			免费注册

[已解决] VBA两表合并

评分

评分

评分

评分