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

8，有条件导出文本文件到桌面（Output、Print、Environ）

‘aa.xls （自编宏之五） Sub daocuwb0408()

Dim rng As Range, cel As Range, Filename$ Dim aa$, col%, i%

Set rng = Range(\For Each cel In rng If cel <> \

If Len(cel) <> 0 Then

aa = Split(cel.Address, \‘取得列的字符 col = cel.Column

Filename = Environ(\桌面\\\ Open Filename For Output As #1 For i = 26 To 245

Data = Cells(i, col).Value

Print #1, Data ‘按列排列数据 Next i Close #1 End If End If Next cel End Sub

9，导出工具（Output、Print、MKDir、Split）

‘导出工具0414.xls （自编宏之五）

‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=47390&page=1 Sub daocuwb0414()

Dim myRng, Filename$, data, f

Dim aa$, n%, i%, Myrc%, Myrh%, Myrj%, wjnm$, shtnm$, m%, bb$, wbnm$ Dim Sht1 As Worksheet, Sht2 As Worksheet, wb As Workbook Application.ScreenUpdating = False Set wb = ThisWorkbook

Set Sht1 = wb.Sheets(\

Myrc = [c5].CurrentRegion.Rows.Count + 4 Myrh = [h65536].End(xlUp).Row Myrj = [j65536].End(xlUp).Row

myRng = Range(\For x = 5 To Myrj

f = Dir(Cells(x, \ '判断文件夹是否已经存在 If f = \ '如果不存在就建立 Next x

For x = 5 To Myrc Sht1.Activate m = 0

wjnm = Split(Sht1.Cells(x, 3), \ '动态工作簿文件名 shtnm = Split(Sht1.Cells(x, 3), \ '动态工作表名 bb = Left(wjnm, Len(wjnm) - 4)

cc = Len(bb) - Len(Replace(bb, \ wbnm = Split(bb, \ Workbooks.Open wjnm

Set Sht2 = ActiveWorkbook.Sheets(shtnm) Sht2.Activate For y = 5 To Myrh

m = m + 1: col = \

Filename = Sht1.Cells(y, \ Range(\

Columns(\ f1 = Split(Sht1.Cells(y, \ '判断列号 For y1 = 1 To Len(f1) temp = Mid(f1, y1, 1)

If temp Like \

col = col & temp '动态区域列号 End If Next y1

n = Cells(65536, col).End(xlUp).Row

Range(Cells(1, \ Set rng = Range(Cells(1, \ Open Filename For Output As #1 For i = 1 To n

data = Cells(i, \ If data = \

Print #1, data '按列排列数据 100:

Next i Close #1

Stop '如果不要暂停，在此行前面加 ' Next y

ActiveWorkbook.Close False Next x

Application.ScreenUpdating = True

End Sub

用山版主部分数组代码替换，速度可加快很多 Sub daocuwb0414()

Dim myRng, Filename$, data, f

Dim aa$, n%, i%, Myrc%, Myrh%, Myrj%, wjnm$, shtnm$, m%, bb$, wbnm$ Dim Sht1 As Worksheet, Sht2 As Worksheet, wb As Workbook Application.ScreenUpdating = False Set wb = ThisWorkbook

Set Sht1 = wb.Sheets(\

Myrc = [c5].CurrentRegion.Rows.Count + 4 Myrh = [h65536].End(xlUp).Row Myrj = [j65536].End(xlUp).Row myRng = Range(\For x = 5 To Myrj

f = Dir(Cells(x, \ '判断文件夹是否已经存在 If f = \ '如果不存在就建立 Next x

For x = 5 To Myrc Sht1.Activate m = 0

wjnm = Split(Sht1.Cells(x, 3), \ '动态工作簿文件名 shtnm = Split(Sht1.Cells(x, 3), \ '动态工作表名

bb = Left(wjnm, Len(wjnm) - 4)

cc = Len(bb) - Len(Replace(bb, \ ‘计算子目录数 wbnm = Split(bb, \ Workbooks.Open wjnm

Set Sht2 = ActiveWorkbook.Sheets(shtnm) Sht2.Activate For y = 5 To Myrh

m = m + 1: col = \

Filename = Sht1.Cells(y, \ Range(\

Columns(\ f1 = Split(Sht1.Cells(y, \ '判断列号 For y1 = 1 To Len(f1) temp = Mid(f1, y1, 1)

If temp Like \

col = col & temp '动态区域列号 End If Next y1

n = Cells(65536, col).End(xlUp).Row

Range(Cells(1, \ Set rng = Range(Cells(1, \