Excel VBA - 文本文件和文件夹操作实例集锦(14)

rng = \ Case 3

rng = \ Case 4

rng = \ End Select

arg = \ Range(rng).Range(\ If j <> 4 Then

bb = bb & ExecuteExcel4Macro(arg) & \ Else

bb = bb & ExecuteExcel4Macro(arg) End If Next

bb = bb & vbCrLf & vbCrLf End If Next End If End With

nm1 = myPath & \ Open nm1 For Output As #1 Print #1, bb Close #1 End Sub

31，导出工作簿到子文件夹

‘http://club.excelhome.net/viewthread.php?tid=598381&pid=4017652&page=1&extra= ‘备份与导入数据0712.xls

Sub Macro1()

Dim nm$, Sht As Worksheet, aa$, MyPath$, pa$, Myc% Dim wb As Workbook, Myr&, fso, Testfolder, Subfolders Set fso = CreateObject(\aa = \设置，总表1，总表2，总表3\MyPath = \成绩数据\\\

If fso.FolderExists(MyPath) Then GoTo 100 End If

Set Testfolder = fso.CreateFolder(MyPath) 100:

For Each Sht In Sheets

If InStr(aa, Sht.Name) = 0 Then

If Left(Sht.Name, 1) = \ pa = \级成绩数据\

ElseIf Left(Sht.Name, 1) = \ pa = \级成绩数据\ Else

pa = \级成绩数据\ End If

Sht.Activate

nm = MyPath & pa & \ Sht.Copy

Set wb = ActiveWorkbook On Error Resume Next

Set Subfolders = Testfolder.Subfolders Subfolders.Add (pa)

wb.SaveAs Filename:=nm wb.Close False Set wb = Nothing

Myr = [a65536].End(xlUp).Row Myc = [iv2].End(xlToLeft).Column

Range(\ ThisWorkbook.Save End If Next

Set fso = Nothing End Sub

32，导出工作簿到文本文件（固定宽度）

‘2014-8-4

‘http://club.excelhome.net/thread-1143191-1-1.html Sub lqxs()

Dim Arr, i&, j&, fd, kg(3), s$, nm$ Sheet1.Activate

fd = Array(15, 50, 30, 30) Arr = [a1].CurrentRegion For i = 1 To UBound(Arr) For j = 0 To UBound(fd) If j = 0 Then

kg(j) = fd(j) - Len(Arr(i, j + 1)) Else

kg(j) = fd(j) - Len(Arr(i, j + 1)) * 2 End If

s = s & Arr(i, j + 1) & Space(kg(j) - 1) & \

Next

s = s & vbCrLf Next

nm = ThisWorkbook.Path & \目标.txt\Open nm For Output As #1 Print #1, s Close (1) End Sub

‘http://club.excelhome.net/thread-599359-1-1.html Sub 生成标贯数据文件0719()

Dim i&, Myr&, Arr, ctx$, j&, ks, js, r%, Arr1(), nm$ Sheets(\标贯表\

Myr = [c65536].End(xlUp).Row Arr = Range(\ For i = 1 To UBound(Arr) If Arr(i, 1) <> \ r = r + 1

ReDim Preserve Arr1(1 To r) Arr1(r) = i End If Next

For i = 1 To r

If i <> r Then

js = Arr1(i + 1) - 1 Else

js = UBound(Arr) End If

ks = Arr1(i)

ctxt = ctxt & Arr(ks, 1) & vbCrLf For j = ks To js

ctxt = ctxt & Arr(j, 19) + 0.45 & vbTab & Arr(j, 20) & vbCrLf Next Next

nm = ThisWorkbook.Path & \目标.txt\ Open nm For Output As #1 Print #1, ctxt Close (1)

MsgBox \标贯数据生成完毕！\End Sub

33，快速导出工作簿到文本文件

‘http://club.excelhome.net/viewthread.php?tid=599685&pid=4081728&page=1&extra=page=1

‘2010-8-1

把多列数据联成一列，速度最快。 Sub daocu()

Dim t, Myr&, ctxt$, Arr, Filename$ t = Timer

Application.ScreenUpdating = False

Filename = ThisWorkbook.Path & \Myr = [a65536].End(xlUp).Row

[k1].Formula = \&\\&\\&\\&\\&\\[k1].AutoFill Range(\

Range(\Open Filename For Output As #1

Arr = WorksheetFunction.Transpose(Range(Cells(1, 11), Cells(Myr, 11))) ctxt = Join(Arr, Chr(13) & Chr(10)) Print #1, ctxt Close #1 [k:k].Clear

Application.ScreenUpdating = True MsgBox Timer - t End Sub

34，移动文件

‘http://club.excelhome.net/viewthread.php?tid=607127&pid=4086715&page=1&extra=page=1

Sub test56()

Dim FSO As Object, f1, pa$, paa$, pab$, f, fc

Set FSO = CreateObject(\ pa = \桌面\\\ paa = pa & \ pab = pa & \

Set f = FSO.GetFolder(paa) Set fc = f.Files For Each f1 In fc

If Right(f1, 4) = \

f1.Move (pab) End If Next

Set FSO = Nothing End Sub

35，快速导出工作簿到文本文件（Shell）

’2010-8-4

‘http://club.excelhome.net/viewthread.php?tid=607075&pid=4089813&page=1&extra=page=1

Private Sub yy() Dim R&, Arr, i&, j&

R = [d65536].End(xlUp).Row Arr = Range(\

Open ThisWorkbook.Path & \底.txt\For i = 1 To UBound(Arr) For j = 1 To 4

S = S & Arr(i, j) & \

If j = 4 Then S = S & vbCrLf Next Next

Print #1, S Close #1

Shell \底.txt\‘或者 Shell \底.txt\End Sub

36，多文本文件导入（FSO.GetFolder）by:一念

‘http://club.excelhome.net/thread-621331-1-1.html Sub GetDt()

Dim Fso, Fl Dim Arr, k%

Set Fso = CreateObject(\

For Each Fl In Fso.getfolder(ThisWorkbook.Path & \ If Fl.Name <> ThisWorkbook.Name Then Workbooks.OpenText (Fl)