自編程序：
Sub cc()
Dim ExApp As New Excel.Application
'聲明一個新的 Excel程序
Dim Pat As String, PatName As String
Dim NBook As Workbook
Dim Hx As Integer, Xm As String
With ExApp
.Visible = False
'程序不可視
.AutomationSecurity = 2
'禁用
新Excel程序的 宏
Pat = ThisWorkbook.Path & "\"
'設置路徑
For Hx = 2 To 163
'循環數據
PatName =
Pat & "a.xls" '設置文件名稱
Set NBook
= .Workbooks.Open(PatName) '打開文件
NBook.Sheets(1).Range("B5").Value = Sheet1.Cells(Hx, "B").Value
'提取數據
NBook.Sheets(1).Range("I5").Value = Sheet1.Cells(Hx,
"C").Value
NBook.Sheets(1).Range("c11").Value = Sheet1.Cells(Hx,
"d").Value
NBook.Sheets(1).Range("f11").Value = Sheet1.Cells(Hx,
"e").Value
NBook.Sheets(1).Range("g11").Value = Sheet1.Cells(Hx,
"f").Value
NBook.Sheets(1).Range("h11").Value = Sheet1.Cells(Hx,
"g").Value
Xm =
Sheet1.Cells(Hx, "B").Value
NBook.SaveCopyAs Pat & Hx - 1 & Xm & ".xls"
'按順序另存爲excel表格
NBook.Close SaveChanges:=False
'不保存
Next
.Quit '退出程序
End With
End Sub
============================================================
參考學習的程序
Sub cc()
Dim ExApp As New Excel.Application
'聲明一個新的 Excel程序
Dim Pat As String, PatName As String
Dim NBook As Workbook
Dim Hx As Integer
With ExApp
.Visible = False
'程序不可視
.AutomationSecurity = 2
'禁用
新Excel程序的 宏
Pat = ThisWorkbook.Path & "\"
'設置路徑
For Hx = 2 To
Sheet1.Range("A65536").End(xlUp).Row
'循環數據
PatName =
Pat & Sheet1.Cells(Hx, "A").Value & ".xls"
'設置文件名稱
If
Len(Dir(PatName)) > 0 Then
'如果文件 存在
Set NBook =
.Workbooks.Open(PatName)
'打開文件
Sheet1.Cells(Hx, "B").Value =
NBook.Sheets("Sheet1").Range("B1").Value
'提取數據
NBook.Close False
'關閉文件,並不保存
End
If
Next
.Quit '退出程序
End With
End Sub
ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" &
StrReverse(Split(ThisWorkbook.Name, ".xls")(0)) & ".xls"
