求大神帮助写一个合并EXCEL表格的VBA

opiona

https://club.excelhome.net/thread-1409141-1-1.html

yangling1975

opiona 发表于 2024-3-6 21:44
https://club.excelhome.net/thread-1409141-1-1.html

学习了，感谢大神的分享~

ykcbf1100

yangling1975 发表于 2024-3-6 12:16
把三十多张卡银行流水粘贴过去后，点击汇总，显示下标越界，请问大神如何处理？

ReDim brr(1 To 10000, 1 To 8)
这一句改成ReDim brr(1 To 100000, 1 To 8)再试试。

tanglf188

参与一下

hhxq001

用此法不用对银行数据进行特别修改，不用将各行数据放到一个工作簿里，只要按提示选择就行，想导入哪个字段的数据就选择哪个字段。



流水选择字段合并.zip (229.61 KB, 下载次数: 2)

2024-3-8 21:12 上传

点击文件名下载附件

ykcbf1100

yangling1975 发表于 2024-3-6 14:24
我上传了三个会出现下标错误的银行流水（会出现问题的不只三个卡号），请大神看一看，怎么解决？

看了你的附件，表格式与原来的不一样啊。你现在这个只有一个表3列数据，你想做什么？

ykcbf1100

yangling1975 发表于 2024-3-6 14:24
我上传了三个会出现下标错误的银行流水（会出现问题的不只三个卡号），请大神看一看，怎么解决？

我重新上传一个代码，你再试试。

要等一下，要审核。

1. Sub ykcbf()   '//2024.3.8
   
2.     Dim arr, brr, d
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     For x = 1 To 8
   
6.         s = sh.Cells(1, x)
   
7.         d(s) = x
   
8.     Next
   
9.     ReDim brr(1 To 100000, 1 To 8)
   
10.     On Error Resume Next
    
11.     For Each sht In Sheets
    
12.         If sht.Name <> sh.Name Then
    
13.             arr = sht.UsedRange
    
14.             For i = 2 To UBound(arr)
    
15.                 If arr(i, 1) <> Empty Then
    
16.                     m = m + 1
    
17.                     For j = 1 To UBound(arr, 2)
    
18.                         s = arr(1, j)
    
19.                         If d.exists(s) Then
    
20.                             brr(m, d(s)) = arr(i, j)
    
21.                         End If
    
22.                     Next
    
23.                 End If
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     With sh
    
28.         .UsedRange.Offset(1).Clear
    
29.         With .[a2].Resize(m, 8)
    
30.             .Value = brr
    
31.             .Borders.LineStyle = 1
    
32.             .HorizontalAlignment = xlCenter
    
33.             .VerticalAlignment = xlCenter
    
34.         End With
    
35.     End With
    
36.     Set d = Nothing
    
37.     MsgBox "OK！"
    
38. End Sub
    

复制代码

hhxq001

ykcbf1100 发表于 2024-1-19 08:37
附件供参考，原则上银行多少都不用改代码。

你这个要保证每张表都保含有相同的字段才行。

ykcbf1100

hhxq001 发表于 2024-3-8 21:20
你这个要保证每张表都保含有相同的字段才行。

你没有相同的字段，怎么提取数据啊

hhxq001

我传的这个不用刻意修改银行的字段，自由选择要匹配的字段，一银行一导入。后续可以再根据自己的需要加上转换格式的代码即可，比如时间格式、文本转数值格式等。