|
- Sub 合并()
- Dim strPath As String, strFile As String
- Dim blHeader As Boolean
- Dim arr
- Dim header
- Dim sht As Worksheet
- strPath = ThisWorkbook.Path & Application.PathSeparator
- strFile = Dir(strPath & "*.xls")
- With Worksheets(1)
- On Error Resume Next
- .UsedRange.Clear
- End With
- Application.ScreenUpdating = False
- Application.DisplayAlerts = False
- Application.EnableEvents = False
- Do While Len(strFile)
- If strFile <> ThisWorkbook.Name Then
- With GetObject(strPath & strFile)
- For Each sht In .Worksheets
- With sht
- If .Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
- If Not blHeader Then
- header = .UsedRange.Rows(1).Value
- With Worksheets(1)
- .Range("a1").Resize(, UBound(header, 2)).Value = header
- blHeader = True
- End With
- End If
- arr = .Range(.Range("a2"), .Range("a1").End(xlDown).End(xlToRight)).Value
- With Worksheets(1)
- .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
- End With
- End If
- End With
- Next
- Windows(.Name).Visible = True
- .Close True
- End With
- End If
- strFile = Dir
- Loop
- With Worksheets(1)
- With .UsedRange
- If .Rows.Count > 1 Then
- .Borders.LineStyle = 1
- .EntireColumn.AutoFit
- End If
- End With
- End With
- Application.ScreenUpdating = True
- MsgBox "合并完成"
- End Sub
复制代码 |
|