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

----------------------------------------------------------------------------------------

-------------------------------------------------------------------------------------------