求助，提取文件夹下所有工作簿第二个工作表内的数据。

lizequn1976

在一个文件夹中有多个工作簿，每个工作簿有多个工作表，我们需要提取每个工作簿中名为“财资01资产负债表”工作表中的某些数据，汇总为一个工作表，第一列为单位名称（提取工作簿的名字），第二列为”货币资金“，第三列为”固定资产原值“，第四列为”固定资产净值“，第五列为”其他应付款“。全部提取年末数。谢谢！

ykcbf1100

年末数是哪一列?表中也没有年末数啊？

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.20
   
2.     Set Fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     st = "财资01资产负债表"
   
6.     b = [{"货币资金","固定资产原值","固定资产净值","其他应付款"}]
   
7.     ReDim brr(1 To 10000, 1 To 5)
   
8.     p = ThisWorkbook.Path & ""
   
9.     For Each f In Fso.GetFolder(p).Files
   
10.         If f.Name Like "*.xlsx" Then
    
11.             fn = Fso.GetBaseName(f)
    
12.             Set wb = Workbooks.Open(f, 0)
    
13.             With wb.Sheets(st)
    
14.                 r = .Cells(Rows.Count, 1).End(3).Row
    
15.                 arr = .Range("a4:h" & r)
    
16.                 wb.Close False
    
17.             End With
    
18.             m = m + 1
    
19.             brr(m, 1) = fn
    
20.             For j = 1 To UBound(b)
    
21.                 For i = 2 To UBound(arr)
    
22.                     If InStr(arr(i, 1), b(j)) Then
    
23.                         brr(m, j + 1) = arr(i, 4)
    
24.                     End If
    
25.                 Next
    
26.                 For i = 2 To UBound(arr)
    
27.                     If InStr(arr(i, 5), b(j)) Then
    
28.                         brr(m, j + 1) = arr(i, 8)
    
29.                     End If
    
30.                 Next
    
31.             Next
    
32.         End If
    
33.     Next f
    
34.     With sh
    
35.         .UsedRange.Offset(1).Clear
    
36.         If m > 0 Then
    
37.             .[a2].Resize(m, 5) = brr
    
38.             .[a2].Resize(m, 5).Borders.LineStyle = 1
    
39.         End If
    
40.     End With
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

limonet

关键字：union all+group+transform

limonet

Sub Limonet()
    Dim Cn As Object, Path$, FileName$, StrSQL$
    Set Cn = CreateObject("ADODB.Connection")
    Path = ThisWorkbook.Path & "\"
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    FileName = Dir(Path & "*.xlsx")
    Do While FileName <> ""
        If FileName <> "汇总表.xlsm" Then
            StrSQL = StrSQL & " Union All Select '" & Split(FileName, ".xlsx")(0) & "' as 单位,* From [Excel 12.0;DataBase=" & Path & FileName & "].[财资01资产负债表$A4:D]  Union All Select '" _
                            & Split(FileName, ".xlsx")(0) & "',* From [Excel 12.0;DataBase=" & Path & FileName & "].[财资01资产负债表$E4:H]"
        End If
        FileName = Dir
    Loop
    StrSQL = "Select 单位,trim(资产) as 资产,期末数 From (" & Mid(StrSQL, 12) & ") Where trim(资产) in('货币资金','固定资产原值','固定资产净值','其他应付款')"
    StrSQL = "Transform -Min(期末数)*-1 Select 单位 From (" & StrSQL & ") Group By 单位 Pivot 资产"
    Range("A2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

lizequn1976

ykcbf1100 发表于 2024-1-20 16:36
附件供参考。。。

感谢！佩服！

lizequn1976

limonet 发表于 2024-1-20 20:39
关键字：union all+group+transform

感谢！感谢！