急急急！！多工作薄合并设置区域问题！！

沧海一粟123123

Sub test()
Dim arr(1 To 10)
Dim mypath, filename As String
Dim k, x, y,m As Integer
Dim wb As Workbook
Dim arr1

mypath = ThisWorkbook.Path & "\明细\"
filename = Dir(mypath & "*.xls")
Do
k = k + 1
arr(k) = filename
filename = Dir
Loop Until filename = ""

For y = 1 To UBound(arr)
    If Len(arr(y)) > 0 Then
        Set wb = Workbooks.Open(mypath & arr(y))
            For x = 1 To wb.Sheets.Count
                i = ThisWorkbook.Sheets(1).Range("g65536").End(xlUp).Row + 1
                m = wb.Sheets(x).Range("e15").End(xlDown).Row
                wb.Sheets(x).Range("e16:s"&m).Copy ThisWorkbook.Sheets(1).Range("g" & i)
                ThisWorkbook.Sheets(1).Range("e" & i) = Left(wb.Name, Len(wb.Name) - 4)
                ThisWorkbook.Sheets(1).Range("f" & i) = wb.Sheets(x).Name
            Next x
        wb.Close True
    End If
Next y

k = Range("g15").End(xlDown).Row
arr1 = Range("e16:f" & k)
For x = 1 To UBound(arr1) - 1
    If arr1(x + 1, 1) = "" Then arr1(x + 1, 1) = arr1(x, 1)
    If arr1(x + 1, 2) = "" Then arr1(x + 1, 2) = arr1(x, 2)
Next x
Range("e16:f" & k) = ""
Range("e16:f" & k) = arr1
End Sub

wzp8888

沧海一粟123123 发表于 2024-11-21 11:34
Sub test()
Dim arr(1 To 10)
Dim mypath, filename As String

感谢老师！！！

wzp8888

蓝桥玄霜 发表于 2024-11-21 11:25

非常感谢蓝桥老师！！！