同一工作簿下多工作表合并！！

kyousn · 发表于 2023-4-12 15:31

各位大佬，能帮忙写段VBA，要求如下：（不要PQ，谢谢）

同一工作簿下多工作表合并后需要在最后一列标注出每个工作表数据的出处，
譬如：一班的数据要在合并后最后一列的数据源处写入“一班”，二班的数据要写入"二班”，以此例推。。。

因为真实的数据有很多工作表，并且行和列也会有追加，所以最好是动态的不要写死，先谢谢大家了！

笨鸟飞不高 · 发表于 2023-4-12 15:53

合并.zip (15.12 KB, 下载次数: 11)

ykcbf1100 · 发表于 2023-4-12 15:54

附件请参考。。。

fengbao008 · 发表于 2023-4-12 16:16

好了，我也是刚学一段时间。

fengbao008 · 发表于 2023-4-12 16:17

看看如何吧，第一次发。

kyousn · 发表于 2023-4-12 16:41

笨鸟飞不高发表于 2023-4-12 15:53

大神好，可以把代码拷贝出来吗？公司内部看不到外部文件的代码，谢谢

kyousn · 发表于 2023-4-12 16:41

ykcbf1100 发表于 2023-4-12 15:54
附件请参考。。。

大神好，可以把代码拷贝出来吗？公司内部看不到外部文件的代码，谢谢

ykcbf1100 · 发表于 2023-4-12 16:44

kyousn 发表于 2023-4-12 16:41
大神好，可以把代码拷贝出来吗？公司内部看不到外部文件的代码，谢谢

可以的，代码在下一楼上传，因为要审核。

ykcbf1100 · 发表于 2023-4-12 16:46

代码如下：

Sub ykcbf() '//2023.4.12
Dim arr, brr(1 To 10000, 1 To 4), d
Set d = CreateObject("scripting.dictionary")
Set Sh = Sheets("合并")
For Each sht In Sheets
If sht.Name <> Sh.Name Then
arr = sht.UsedRange
For i = 2 To UBound(arr)
s = arr(i, 1) & "|" & arr(i, 2) & "|" & sht.Name
If s <> Empty Then
d(s) = arr(i, 3)
End If
Next
End If
Next
For Each k In d.keys
m = m + 1
brr(m, 1) = Split(k, "|")(0)
brr(m, 2) = Split(k, "|")(1)
brr(m, 3) = d(k)
brr(m, 4) = Split(k, "|")(2)
Next
With Sh
.UsedRange.Offset(1).Clear
.[a2].Resize(m, 4) = brr
.[a2].Resize(m, 4).Borders.LineStyle = 1
End With
End Sub

复制代码

kyousn · 发表于 2023-4-12 16:49

ykcbf1100 发表于 2023-4-12 16:44
可以的，代码在下一楼上传，因为要审核。

知道了，谢谢您的帮忙

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

[求助] 同一工作簿下多工作表合并！！

评分

评分