Sub 合并一个文件夹下全部xls文件中sheet到一个xls的sheet()
workDir = ThisWorkbook.Path \'当前xls文件所在的目录绝对路径
\'MsgBox workDir, 0, "workDir"
bookname = ThisWorkbook.Name \'当前xls文件名
\'MsgBox bookname, 0, "bookname"
file = Dir(workDir & "\*.xls") \'workDir目录下第一个文件名
\'MsgBox file, 0, "file"
Application.ScreenUpdating = False
Do While file <> ""
If file <> bookname Then
Set wk2 = Workbooks.Open(workDir & "\" & file)
For Each sht2 In wk2.Sheets
\'MsgBox sht2.Name, 0, "Sheets(j).Name"
X = Range("A65536").End(xlUp).Row + 1
Cells(X, 1) = sht2.Name
sht2.Range("D2").Copy Cells(X, 2)
Next
wk2.Close False
End If
file = Dir \'若第二次调用 Dir 函数，但不带任何参数，则函数将返回同一目录下的下一个 *.xls 文件
Loop
Application.ScreenUpdating = True
MsgBox "合并完毕！", vbInformation, "提示"
End Sub
---------------------------------------------------------------------------------------------
Sub 将一个sheet中的域名IP映射写到一个新的xls文件中，每个sheet对应一个域名()
Set sh = ActiveSheet
r = sh.Range("a65536").End(xlUp).Row\'总共域名的个数
Workbooks.Add.SaveAs ThisWorkbook.Path & "\" & r & "个工作表的工作薄.xls"
For i = 1 To r
Set mySheet = ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksheets.Count))
mySheet.Name = sh.Range("a" & i).Value \'域名
mySheet.Range("d2") = sh.Range("b" & i).Value \'IP地址
\'MsgBox sh.Range("a" & i).Value, 0, "aaa"
\'MsgBox mySheet.Name, 0, "aaa"
mySheet.Range("a1:f1").EntireColumn.AutoFit \'根据内容自动调整列宽
Next
\'删除新建xls文件时默认的三个空sheet
Application.DisplayAlerts = False \'删除时不用确认
Worksheets("sheet1").Delete
Worksheets("sheet2").Delete
Worksheets("sheet3").Delete
End Sub
----------------------------------------------------------------------------------------
-------------------------------------------------------------------------------------------