|
发表于 2017-6-16 19:57
|
显示全部楼层
本楼为最佳答案
本帖最后由 chart888 于 2017-6-16 20:01 编辑
- Private Sub CommandButton1_Click()
- Dim MyPath$, MyName$, sh As Workbook, sht As Worksheet, m&
- On Error Resume Next
- Application.ScreenUpdating = False
- MyPath = ThisWorkbook.Path & ""
- MyName = Dir(MyPath & "*.*")
- Application.ScreenUpdating = False
- Do While MyName <> ""
- If MyName <> ThisWorkbook.Name Then
- Set sh = GetObject(MyPath & MyName)
- For Each sht In sh.Worksheets
- If sht.Name Like "*基本信息*" Then
- With ThisWorkbook.Worksheets("Sheet1")
- m = .Range("A65536").End(xlUp).Row + 1
- .Range("A" & m) = Split(sht.Range("B1"), "个人")(0)
- sht.Range("C2:C18").Copy
- .Cells(m, 2).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:= _
- False, Transpose:=True
- End With
- End If
- Next
- Workbooks(MyName).Close True
- End If
- MyName = Dir
- Loop
- ThisWorkbook.Worksheets("Sheet1").Range("A1:R1").EntireColumn.AutoFit
- Application.ScreenUpdating = True
- End Sub
复制代码 |
|