excel保存sheet
- 格式：pdf
- 大小：275.66 KB
- 文档页数：4
下载文档原格式
- 1、下载文档前请自行甄别文档内容的完整性，平台不提供额外的编辑、内容补充、找答案等附加服务。
- 2、"仅部分预览"的文档,不可在线预览部分如存在完整性等问题,可反馈申请退款(可完整预览的文档不适用该条件!)。
- 3、如文档侵犯您的权益，请联系客服反馈,我们会尽快为您处理(人工客服工作时间：9:00-18:30)。
Private Sub SplitExcelFile()
Dim MyName, dic, Did, i, t, F, TT, MyFileName1, MyFileName2, MyExcelFileName
Dim PathStr As String
Dim TPath As String, XSheet As Worksheet
Dim oFso
Dim wb As Workbook
Dim r As Range, c As Range
Dim sTemp As String
Dim dlgOpen As FileDialog
Set dlgOpen =
Application.FileDialog(msoFileDialogFolderPicker) With dlgOpen
If.Show =-1Then
PathStr =.SelectedItems(1)
End If
End With
Set dlgOpen =Nothing
PathStr = PathStr &"\"
Set oFso =
CreateObject("Scripting.FileSystemObject")
Cells(2,2)= PathStr
'将指定目录下（包括子目录）添加到第一个字典对象中，将目录下的Excel文件添加到第二个字典对象中
Set dic = CreateObject("Scripting.Dictionary") 'create an dic object
Set Did = CreateObject("Scripting.Dictionary") dic.Add (PathStr),""
i =0
Do While i < dic.Count
Ke = dic.keys '开始遍历字典
MyName = Dir(Ke(i), vbDirectory)'find directories
Do While MyName <>""
If MyName <>"."And MyName <>".."Then
If(GetAttr(Ke(i)& MyName)And vbDirectory)= vbDirectory Then'if it's a sub folder, then append it to dic object
dic.Add (Ke(i)& MyName &"\"), ""
End If
End If
MyName = Dir '继续遍历寻找
Loop
i = i +1
Loop
Did.Add ("File List"),""'find all of the excel files under specified path
For Each Ke In dic.keys
MyFileName1 = Dir(Ke &"*.xls")
Do While MyFileName1 <>""
Did.Add (Ke & MyFileName1),""
MyFileName1 = Dir
Loop
MyFileName2 = Dir(Ke &"*.sql")
Do While MyFileName2 <>""
oFso.Deletefile Ke & MyFileName2
MyFileName2 = Dir
Loop
Next
For Each Sh In ThisWorkbook.Worksheets '如果当前工作薄中存在该sheet则删除之，重新添加内容
If ="XLS File List"Then
Sheets("XLS File List").Cells.Delete
F =True
Exit For
Else
F =False
End If
Next
If Not F Then
="XLS File List"
End If
If Did.Count >1Then
Sheets("XLS File List").[A2] =1
Sheets("XLS File List").[A2].DataSeries 2, Step:=1,Stop:=Did.Count -1
End If
Sheets("XLS File List").[B1].Resize(Did.Count, 1)= WorksheetFunction.Transpose(Did.keys)
Application.ScreenUpdating =False
Application.DisplayAlerts =False
j =0
For Each excelkey In Did.keys
MyExcelFileName = Dir(excelkey)' excelkey: file path, MyExcelFileName: file name.
If MyExcelFileName <>""Then
Set wb = Workbooks.Open(excelkey)
TPath =
oFso.GetParentFolderName(excelkey)
For Each XSheet In wb.Sheets
' XSheet.Activate
If Not(InStr(UCase(), "LOG")>0Or InStr(UCase(),"REMOVE")) And XSheet.Visible Then'如果Excel文件的sheet名还有log或者remove字样则不予保存，如果sheet隐藏不予保存
XSheet.Activate
Open TPath &"\Scripts\"& oFso.GetBaseName(MyExcelFileName)&" - "& &".txt"For Output As#1
With edRange
For Each r In.Rows
sTemp =""
For Each c In r.Cells