Sub Macro1()
Dim MyPath$, MyName$, arr, sh As Worksheet, d As Object, i&
Set d = CreateObject("scripting.dictionary")
MyPath = ThisWorkbook.Path & "\"
MyName = Dir(MyPath & "*.xls")
Application.ScreenUpdating = False
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
With Workbooks.Open(MyPath & MyName)
With .Sheets(1)
arr = .Range(.[a1], .[IV1].End(1))
End With
For i = 2 To UBound(arr, 2)
d(arr(1, i)) = i
Next
For Each sh In .Sheets
If sh.Name <> .Sheets(1).Name Then
With sh
With .Range("A1").CurrentRegion
arr = .Value
.Offset(0, 1).ClearContents
End With
For i = 2 To UBound(arr, 2)
.Cells(1, d(arr(1, i))).Resize(UBound(arr)) = WorksheetFunction.Index(arr, 0, i)
Next
End With
End If
Next
.Close True
End With
d.RemoveAll
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
MsgBox "完毕"
End Sub