把工作薄竖列汇总到一个总表中之后改成横列

wewes

把工作薄竖列汇总到一个总表中之后改成横列。谢谢

总表第一个是标题 ，第二行是数据

分表 A列是标题，B列是数据

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()              '//2024.8.12
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 1000, 1 To 200)
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase$(f.Name) Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 fn = fso.GetBaseName(f)
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 With wb.Sheets(1)
    
13.                     r = .Cells(Rows.Count, 1).End(3).Row
    
14.                     arr = .[a1].Resize(r, 2)
    
15.                     wb.Close False
    
16.                 End With
    
17.                 m = m + 1
    
18.                 For i = 1 To UBound(arr)
    
19.                     brr(m, i) = arr(i, 2)
    
20.                 Next
    
21.             End If
    
22.         End If
    
23.     Next f
    
24.     With sh
    
25.         .UsedRange.Offset(1).ClearContents
    
26.         .[a2].Resize(m, r) = brr
    
27.     End With
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "OK！"
    
30. End Sub
    

复制代码

gwjkkkkk

Option Explicit
Sub test()
    Dim strFileName$, strPath$, Rng As Range, iRow&
   
    Application.ScreenUpdating = False
    strPath = ThisWorkbook.Path & "\"
   
    [A1].CurrentRegion.Offset(1).Clear
    strFileName = Dir(strPath & "*.xls*")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                With .Worksheets(1).[A1].CurrentRegion
                    .Columns(2).Copy
                    iRow = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cells(iRow, 1).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
                     False, Transpose:=True
                End With
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考。。。

wewes

ykcbf1100 发表于 2024-8-12 16:26
参与一下。。。

你好 当总表里没有标题行的时候，它这个程序代码只提取分表的内容，标题没有提取放到第一行。能帮稍微改一下吗

ykcbf1100

wewes 发表于 2024-8-14 10:58
你好 当总表里没有标题行的时候，它这个程序代码只提取分表的内容，标题没有提取放到第一行。能帮稍微改 ...

我明白你的意思了，就是标题行也提取过去。

ykcbf1100

改一下，连标题行一起提取。

1. Sub ykcbf()              '//2024.8.14
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     p = ThisWorkbook.Path & ""
   
6.     ReDim brr(1 To 1000, 1 To 200)
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase$(f.Name) Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 fn = fso.GetBaseName(f)
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 n = n + 1
    
13.                 With wb.Sheets(1)
    
14.                     r = .Cells(Rows.Count, 1).End(3).Row
    
15.                     arr = .[a1].Resize(r, 2)
    
16.                     wb.Close False
    
17.                 End With
    
18.                 If n = 1 Then
    
19.                     m = m + 1
    
20.                     For i = 1 To UBound(arr)
    
21.                         brr(m, i) = arr(i, 1)
    
22.                     Next
    
23.                 End If
    
24.                 m = m + 1
    
25.                 For i = 1 To UBound(arr)
    
26.                     brr(m, i) = arr(i, 2)
    
27.                 Next
    
28.             End If
    
29.         End If
    
30.     Next f
    
31.     With sh
    
32.         .UsedRange.ClearContents
    
33.         .[a1].Resize(m, r) = brr
    
34.     End With
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

songshihai

行字段顺序不一致也可以!!!!!!!!!!!!!!!!!!!!