多工作簿（网银明细）特定列余额提取和明细提取

[广州]飞天猪

真诚求助!  
岗位涉及网银数据的提取，每周五必须统计各个网银的余额和收入情况。希望能借助VBA在不打开工作簿的情况下统计数据，其中余额为各个网银明细的余额列的最后一个行数据，收入为各个收入列数据（金额、对方账户、交易时间）的提取。数据存储的原因存在多个子文件夹。数据提取存在难点还有：不同银行的格式不同，名称也不同。余额有3种说法（都有“余额”两个字）：余额、账户余额、本次余额（仅一家）；收入说法有(或者包含“贷方”或者包含“收入”）：贷方发生额（收入）、贷方金额（收入）、收入金额、收入、贷方金额（厦门银行）、贷方发生额；对方单位的说法不一，但都包含“对方”2个字。

汇总表格中包含了文件夹和工作表名称的提取，如果工作表名称能显示为超链接就更好了！

zpy2

https://club.excelhome.net/thread-1613596-1-1.html?_dsign=763768f7

[广州]飞天猪

这是采用用合并工作表做出来的？

[广州]飞天猪

这个貌似无法解决提取不同银行账户的余额

dj5121766

判断表内前面几行和其他表存在的唯一数据（可以是一个单元格，也可以是几个单元格数据），匹配相关取数列。其他的就是多文件夹下的文件打开了，数据写入了、

3190496160

Sub ListFilesTest() '
Application.ScreenUpdating = False '
Dim rn As Range
T = Timer '
Set d = CreateObject("Scripting.Dictionary")
With ActiveSheet
    xh = 1
    .[a1].CurrentRegion.Offset(1).Borders.LineStyle = 0
    .[a1].CurrentRegion.Offset(1) = Empty
    myPath$ = ThisWorkbook.Path & "\网银明细\"
    If Right(myPath, 1) <> "" Then myPath = myPath & "" '
    arr = ListAllFsoDic(myPath, 1) '
    For i = 0 To UBound(arr) '
        f = Dir(arr(i) & "\*.xls*") '
        Do While f <> "" '
            If f <> ThisWorkbook.Name Then '
                xh = xh + 1
                rr = Split(arr(i), "\")
                .Range("a" & xh).Hyperlinks.Add Anchor:=.Range("a" & xh), Address:=arr(i) & "\" & f, TextToDisplay:=Split(f, ".")(0)
                .Cells(xh, 2) = rr(UBound(rr) - 2)
                .Cells(xh, 3) = rr(UBound(rr) - 1)
                .Cells(xh, 4) = rr(UBound(rr))
                Set wb = Workbooks.Open(arr(i) & "\" & f, 0)
                Set sht = wb.Worksheets(1)
                .Range("e" & xh).Hyperlinks.Add Anchor:=.Range("e" & xh), Address:=arr(i) & "\" & f, TextToDisplay:=sht.Name
                Set rn = sht.Rows("1:20").Find("余额", , , , , , 1)
                If Not rn Is Nothing Then
                    h = rn.Column
                    r = sht.Cells(Rows.Count, h).End(xlUp)
                    .Cells(xh, 6) = r
                End If
                wb.Close False
            End If '
        f = Dir '
        Loop '
    Next i '
    .[a1].CurrentRegion.Offset(1).Borders.LineStyle = 1
End With
TT = Timer - T '
MsgBox "耗时：" & Format(TT, "0.00") & "秒！" '
Application.ScreenUpdating = True '
End Sub
Function ListAllFsoDic(myPath$, Optional k = 0) '使用2个字典但无需递归的遍历过程
   Dim i&, j&
  Set d1 = CreateObject("Scripting.Dictionary") '字典d1记录子文件夹的绝对路径名
  Set d2 = CreateObject("Scripting.Dictionary") '字典d2记录文件名 （文件夹和文件分开处理）
   d1(myPath) = ""           '以当前路径myPath作为起始记录，以便开始循环检查
  Set Fso = CreateObject("Scripting.FileSystemObject")
  Do While i < d1.Count
  '当字典1文件夹中有未遍历处理的key存在时进行Do循环 直到 i=d1.Count即所有子文件夹都已处理时停止
     kr = d1.Keys '取出文件夹中所有的key即所有子文件夹路径 （注意每次都要更新）
    For Each f In Fso.GetFolder(kr(i)).Files '遍历该子文件夹中所有文件 （注意仅从新的kr(i) 开始）
         j = j + 1: d2(j) = f.Name
         '把该子文件夹内的所有文件名作为字典Item项加入字典d2 (为防止文件重名不能用key属性)
      Next
      i = i + 1 '已经处理过的子文件夹数目 i +1 （避免下次产生重复处理）
      For Each fd In Fso.GetFolder(kr(i - 1)).SubFolders '遍历该文件夹中所有新的子文件夹
          d1(fd.Path) = " " & fd.Name & ""
          '把新的子文件夹路径存入字典d1以便在下一轮循环中处理
      Next
  Loop
  If k Then ListAllFsoDic = d1.Keys Else ListAllFsoDic = d2.Items
  '如果参数=1则列出字典d1中所有子文件夹的路径名 (如使用d1.Items则仅列出子文件夹名称不含路径)
   '如果参数=0则默认列出字典d2中Items即所有文件名
End Function

3190496160

明细数据.rar (434.1 KB, 下载次数: 23)

2023-2-5 12:22 上传

点击文件名下载附件

3190496160

只写了提取余额的代码，收入的，自己依样画葫芦吧

blackttea1

感兴趣，谢谢分享

[广州]飞天猪

非常感谢！！  我好好参考学习下