求助代码

施学明

将“表格提取”文件夹中所有类似表1、表2工作表中的数据提取合并到“表格打印”工作簿的“sheet1”的工作表中，如示范所示

quqiyuan

根据你都放在一个单元格制作。。。仅供参考。。。

quqiyuan

代码如下。。。
Sub test()
    Application.ScreenUpdating = False
    Set sht = ThisWorkbook.Sheets(1)
    Set fso = CreateObject("scripting.filesystemobject")
    p = ThisWorkbook.Path & "\表格提取\"
    Set fn = fso.getfolder(p).Files
    For Each f In fn
        If LCase(f.Name) Like "*.xls*" Then
            With Workbooks.Open(f, 0)
               For Each sh In .Worksheets
                   arr = sh.Cells(2, 1).Resize(, 4)
                   For i = 1 To 4
                       If sht.Cells(2, i) = Empty Then
                           sht.Cells(2, 1).Resize(, 4) = arr: Exit For
                       Else
                           sht.Cells(2, i) = sht.Cells(2, i) & Chr(10) & arr(1, i)
                       End If
                   Next
               Next
               .Close 0
            End With
        End If
    Next
    Application.ScreenUpdating = True
    Beep
End Sub

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.28
   
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 10000, 1 To 4)
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase$(f.Name) Like "*.xls*" Then
   
9.             fn = fso.GetBaseName(f)
   
10.             m = m + 1
    
11.             Set wb = Workbooks.Open(f, 0)
    
12.             arr = wb.Sheets(1).UsedRange
    
13.             wb.Close False
    
14.             If m = 1 Then
    
15.                 For j = 1 To UBound(arr, 2)
    
16.                     brr(1, j) = arr(2, j)
    
17.                 Next
    
18.             Else
    
19.                 For j = 1 To UBound(arr, 2)
    
20.                     brr(1, j) = brr(1, j) & Chr(10) & arr(2, j)
    
21.                 Next
    
22.             End If
    
23.         End If
    
24.     Next f
    
25.     With sh
    
26.         .UsedRange.Offset(1).ClearContents
    
27.         .[a2].Resize(1, 4) = brr
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

peteryhr

试一下。。。。。。。。。。。

peteryhr

Sub byPeteryhr()
    Dim j&, p$, f$, sht As Worksheet, wb As Workbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    p = ThisWorkbook.Path & "\表格提取\"
    f = Dir(p & "*.xls*")
    With ThisWorkbook.Sheets(1)
        .Range("A2:D2").ClearContents
        Do While f <> ""
            Set wb = Workbooks.Open(p & f)
            Set sht = wb.Sheets(1)
                For j = 1 To 4
                    .Cells(2, j).Value = sht.Cells(2, j).Value & vbCrLf & .Cells(2, j).Value
                Next
            wb.Close False
            f = Dir
        Loop
    End With
    Application.ScreenUpdating = True
End Sub

施学明

谢谢您的热心相助