|
发表于 2017-6-27 18:05
|
显示全部楼层
本楼为最佳答案
- Private Sub CommandButton1_Click()
- On Error Resume Next
- Dim Arr, MyPath, MyName
- Dim r&, i&
- Dim sh As Workbook
- Application.ScreenUpdating = False
- MyPath = ThisWorkbook.Path & ""
- MyName = Dir(MyPath & "*.*")
- Do While MyName <> ""
- If MyName <> ThisWorkbook.Name Then
- With ThisWorkbook.Worksheets("Sheet1")
- Set sh = GetObject(MyPath & MyName)
- r = Cells(Rows.Count, 1).End(xlUp).Row
- Arr = sh.ActiveSheet.[A1].CurrentRegion
- For i = 7 To UBound(Arr)
- r = r + 1
- .Cells(r, 1) = Arr(3, 4): .Cells(r, 2) = Arr(3, 5): .Cells(r, 3) = Arr(3, 6)
- .Cells(r, 4) = Arr(3, 7): .Cells(r, 5) = Arr(3, 10):
- .Cells(r, 6) = Arr(i, 2): .Cells(r, 7) = Arr(i, 3): .Cells(r, 8) = Arr(i, 7)
- .Cells(r, 9) = Arr(i, 4): .Cells(r, 10) = Arr(i, 5): .Cells(r, 12) = Arr(i, 6)
- Next
- Workbooks(MyName).Close True
- End With
- End If
- MyName = Dir
- Loop
- With ThisWorkbook.Worksheets("Sheet1")
- .Range("A1:L1").EntireColumn.AutoFit
- With .Range("A2").CurrentRegion.Borders
- .LineStyle = xlContinuous
- .Weight = xlThin
- End With
- End With
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|