Excel VBA_文本文件和文件夹操作实例集锦

1，导入文本数据（QueryTables）‘110419.xlsSub daorwb()' 2008-4-19Columns("a:g").ClearContents‘文本文件名放在[y2]单元格，两文件在同一个文件夹With ActiveSheet.QueryTables.Add(Connection:= _"TEXT;" & ThisWorkbook.Path & "\" & [y2], Destination:=Range("A1")).FieldNames = True.PreserveFormatting = True.RefreshStyle = xlInsertDeleteCells.SaveData = True.AdjustColumnWidth = False.TextFilePromptOnRefresh = False.TextFilePlatform = 936.TextFileStartRow = 1.TextFileParseType = xlFixedWidth.TextFileTextQualifier = xlTextQualifierDoubleQuote.TextFileTabDelimiter = True.TextFileColumnDataTypes = Array(2, 1, 1, 1, 1, 1, 1).TextFileFixedColumnWidths = Array(1, 1, 1, 1, 1, 1).TextFileTrailingMinusNumbers = True.Refresh BackgroundQuery:=FalseEnd WithEnd Sub2，从文本文件中复制部分数据（OpenText方法）‘/dispbbs.asp?BoardID=92&ID=28958&replyID=&skin=1 Sub Macro1()' 2007-10-18 （自编宏之四）'从文本文件中复制部分数据‘Book1017.xls+test1017.txtApplication.DisplayAlerts = FalseDim Myflnm$Myflnm = ThisWorkbook.Path & "\test1017.txt"Workbooks.OpenText Filename:=Myflnm, Origin _:=xlWindows, StartRow:=37, DataType:=xlDelimited, TextQualifier:= _xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _Array(2, 1)), TrailingMinusNumbers:=TrueSelection.CurrentRegion.CopyThisWorkbook.Activate[a1].SelectActiveSheet.PasteWindows("test1017.txt").ActivateActiveWorkbook.CloseApplication.DisplayAlerts = TrueEnd Sub3，超链接自动生成（Hyperlink公式中引用单元格）Sub caolj1108()‘超链接1108.xls （自编宏之四）Dim Myr%, aa$, x%Myr = [a65536].End(xlUp).RowFor x = 4 To Myr - 3aa = Cells(x, 1)If aa <> "" And InStr(aa, "小") = 0 And InStr(aa, "月") = 0 ThenCells(x, "n").Formula = "=if(--(right(rc[-13],2))<=50,mid(rc[-13],2,2)&""01-""&mid(rc[-13],2,2)&""50"",mid(rc[-13],2,2) &""51-""&text(mid(rc[-13],3,1)+1,""00"")&""00"")" ‘辅助列公式Cells(x, "o").Formula = "=HYPERLINK(""\\Tfknit\texford\生產通知單類\2007生產通知單\""&rc[-1]&""\""&RIGHT(rc[-14],4)&""\""&rc[-14]&""生產進度明細表.xls"",""進度明細表"")"Cells(x, "p").Formula = "=HYPERLINK(""\\Tfknit\texford\生產通知單類\2007生產通知單\""&rc[-2]&""\""&RIGHT(rc[-15],4)&""\""&rc[-15]&""生產通知單.xls"",rc[-15])"Cells(x, "q").Formula = "=HYPERLINK(""\\Tfknit\texford\生產通知單類\2007生產通知單\""&rc[-3]&""\""&RIGHT(rc[-16],4)&""\""&rc[-16]&""PO.pdf"")"End IfNext xEnd Sub4，批量插入指定文件夹图片（FileSearch 函数）Sub plcrtp1111()（自编宏之四）'批量插入指定文件夹图片Dim myFs As FileSearchDim myPath As StringDim i As Long, n As LongSet myFs = Application.FileSearchmyPath = "C:\My Documents\My Pictures\" '你的图片文件夹With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypePhotoDrawFiles.Filename = "*.jpg"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountMsgBox "该文件夹里有" & n & "个jpg文件"ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Cells(i, 1) = myfile(i)NextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSet myFs = NothingCall Macro1End SubSub Macro1()'Dim Myr%, x%, aa$Myr = [a65536].End(xlUp).RowFor x = 1 To Myraa = Cells(x, 1)Cells(x, 2).SelectActiveSheet.Pictures.Insert (aa)Next xEnd Sub5，查询指定文件夹图片（Pictures.Insert 函数）Book1113.xls （自编宏之四）Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Myr%, x%, aa$Dim myPath As StringMyr = [a65536].End(xlUp).RowIf Target.Address <> "$D$1" Then Exit SubmyPath = "F:\论坛数据\Excel论坛\未完成\相片\" '你的图片文件夹aa = myPath & [d2] & ".jpg"Cells(2, 6).SelectActiveSheet.Pictures.Insert (aa)End Sub6，导出N列数据到文本文件/dispbbs.asp?BoardID=2&ID=280260&replyID=&skin=0 ‘求修改代码.xls （自编宏之四）Sub 导出N列数据()Dim Filename As StringDim rows As Long, cols As IntegerDim i As Long, j As IntegerDim Data As VariantDim cell As RangeDim Arr, T, x%, fname$, fdir, N%fdir = ThisWorkbook.Path & "\号码"N = 7Filename = fdir & "\" & (N - 6) & ".txt"Range("g5:g1004").Copy [am5]Range("o5:o1004").Copy [an5]Range("t5:t1004").Copy [ao5]Range("z5:z1004").Copy [ap5]Range("am5:ap1004").SelectSet cell = Selectioncols = cell.Columns.Countrows = cell.rows.CountOpen Filename For Output As #1For i = 1 To rowsFor j = 1 To colsData = cell.Cells(i, j).ValueIf IsEmpty(cell.Cells(i, j)) Then Data = " "If j <> cols ThenWrite #1, Data;ElseWrite #1, DataEnd IfNext jNext iClose #1Range("am5:ap1004").ClearContentsEnd Sub7，同文件夹根据文本数据修改（Opentext，分列，Name）‘Mybk1.xls(QQ) （自编宏之五）Sub 批量修改文件名()'同文件夹根据文本文件数据修改'08-02-16Dim OldName As String, NewName As StringDim Myflnm$Dim Myr%, x%, Arr, aa$, bb$On Error Resume NextApplication.DisplayAlerts = FalseMyflnm = ThisWorkbook.Path & "\目录.txt"Workbooks.OpenText Filename:=Myflnm, Origin _:=xlWindows, StartRow:=2, DataType:=xlDelimited, TextQualifier:= _xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), _Array(2, 1)), TrailingMinusNumbers:=TrueColumns("A:A").SelectSelection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(3, 1)), TrailingMinusNumbers:=TrueSelection.CurrentRegion.CopyThisWorkbook.Activate[a1].SelectActiveSheet.PasteWindows("目录.txt").ActivateActiveWorkbook.CloseMyr = [a65536].End(xlUp).RowArr = Range("a1:b" & Myr)For x = 1 To Myraa = Format(Arr(x, 1), "000")bb = Trim(Arr(x, 2))OldName = ThisWorkbook.Path & "\" & aa & ".swf" '原文件名NewName = ThisWorkbook.Path & "\" & bb & ".swf" '新文件名Name OldName As NewName '在同一个文件夹更改文件名Next xApplication.DisplayAlerts = TrueEnd Sub8，有条件导出文本文件到桌面（Output、Print、Environ）‘aa.xls （自编宏之五）Sub daocuwb0408()Dim rng As Range, cel As Range, Filename$Dim aa$, col%, i%Set rng = Range("f1:ik1")For Each cel In rngIf cel <> " " ThenIf Len(cel) <> 0 Thenaa = Split(cel.Address, "$")(1) ‘取得列的字符col = cel.ColumnFilename = Environ("USERPROFILE") & "\桌面\" & aa & ".txt"Open Filename For Output As #1For i = 26 To 245Data = Cells(i, col).ValuePrint #1, Data ‘按列排列数据Next iClose #1End IfEnd IfNext celEnd Sub9，导出工具（Output、Print、MKDir、Split）‘导出工具0414.xls （自编宏之五）‘/dispbbs.asp?boardID=5&ID=47390&page=1Sub daocuwb0414()Dim myRng, Filename$, data, fDim aa$, n%, i%, Myrc%, Myrh%, Myrj%, wjnm$, shtnm$, m%, bb$, wbnm$Dim Sht1 As Worksheet, Sht2 As Worksheet, wb As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookSet Sht1 = wb.Sheets("Sheet1")Myrc = [c5].CurrentRegion.Rows.Count + 4Myrh = [h65536].End(xlUp).RowMyrj = [j65536].End(xlUp).RowmyRng = Range("h5:h" & Myrh)For x = 5 To Myrjf = Dir(Cells(x, "j"), vbDirectory) '判断文件夹是否已经存在If f = "" Then MkDir (Cells(x, "j")) '如果不存在就建立Next xFor x = 5 To MyrcSht1.Activatem = 0wjnm = Split(Sht1.Cells(x, 3), ",")(0) '动态工作簿文件名shtnm = Split(Sht1.Cells(x, 3), ",")(1) '动态工作表名bb = Left(wjnm, Len(wjnm) - 4)cc = Len(bb) - Len(Replace(bb, "\", ""))wbnm = Split(bb, "\")(cc)Workbooks.Open wjnmSet Sht2 = ActiveWorkbook.Sheets(shtnm)Sht2.ActivateFor y = 5 To Myrhm = m + 1: col = ""Filename = Sht1.Cells(y, "j") & wbnm & ".txt"Range("bh:bh").ClearContentsColumns("bh:bh").NumberFormatLocal = "@"f1 = Split(Sht1.Cells(y, "h"), ":")(0) '判断列号For y1 = 1 To Len(f1)temp = Mid(f1, y1, 1)If temp Like "[A-Za-z]" Thencol = col & temp '动态区域列号End IfNext y1n = Cells(65536, col).End(xlUp).RowRange(Cells(1, "bh"), Cells(n, "bh")) = Range(Cells(1, col), Cells(n, col)).ValueSet rng = Range(Cells(1, "bh"), Cells(n, "bh"))Open Filename For Output As #1For i = 1 To ndata = Cells(i, "bh").ValueIf data = "" Then GoTo 100Print #1, data '按列排列数据100:Next iClose #1Stop '如果不要暂停，在此行前面加'Next yActiveWorkbook.Close FalseNext xApplication.ScreenUpdating = TrueEnd Sub用山版主部分数组代码替换，速度可加快很多Sub daocuwb0414()Dim myRng, Filename$, data, fDim aa$, n%, i%, Myrc%, Myrh%, Myrj%, wjnm$, shtnm$, m%, bb$, wbnm$Dim Sht1 As Worksheet, Sht2 As Worksheet, wb As WorkbookApplication.ScreenUpdating = FalseSet wb = ThisWorkbookSet Sht1 = wb.Sheets("Sheet1")Myrc = [c5].CurrentRegion.Rows.Count + 4Myrh = [h65536].End(xlUp).RowMyrj = [j65536].End(xlUp).RowmyRng = Range("h5:h" & Myrh)For x = 5 To Myrjf = Dir(Cells(x, "j"), vbDirectory) '判断文件夹是否已经存在If f = "" Then MkDir (Cells(x, "j")) '如果不存在就建立Next xFor x = 5 To MyrcSht1.Activatem = 0wjnm = Split(Sht1.Cells(x, 3), ",")(0) '动态工作簿文件名shtnm = Split(Sht1.Cells(x, 3), ",")(1) '动态工作表名bb = Left(wjnm, Len(wjnm) - 4)cc = Len(bb) - Len(Replace(bb, "\", "")) ‘计算子目录数wbnm = Split(bb, "\")(cc)Workbooks.Open wjnmSet Sht2 = ActiveWorkbook.Sheets(shtnm)Sht2.ActivateFor y = 5 To Myrhm = m + 1: col = ""Filename = Sht1.Cells(y, "j") & wbnm & ".txt"Range("bh:bh").ClearContentsColumns("bh:bh").NumberFormatLocal = "@"f1 = Split(Sht1.Cells(y, "h"), ":")(0) '判断列号For y1 = 1 To Len(f1)temp = Mid(f1, y1, 1)If temp Like "[A-Za-z]" Thencol = col & temp '动态区域列号End IfNext y1n = Cells(65536, col).End(xlUp).RowRange(Cells(1, "bh"), Cells(n, "bh")) = Range(Cells(1, col), Cells(n, col)).ValueSet rng = Range(Cells(1, "bh"), Cells(n, "bh"))'山版主代码运用数组及join函数一次转换连接成文本arr = WorksheetFunction.Transpose(Range(Cells(3, "bh"), Cells(n, "bh"))) '把当列数据(从第3行开始)保存到数组ctxt = Join(arr, Chr(13) & Chr(10)) '连接为文本Do While InStr(ctxt, " ") > 0 '删除空格ctxt = Replace(ctxt, " ", "")LoopDo While InStr(ctxt, Chr(13) & Chr(10) & Chr(13) & Chr(10)) > 0ctxt = Replace(ctxt, Chr(13) & Chr(10) & Chr(13) & Chr(10), Chr(13) & Chr(10))LoopOpen Filename For Output As #1'Open cPath2(i, 1) & Replace(MyName, ".xls", ".txt") For Output As #1 '打开文本文件Print #1, ctxt '将数据一次写入文本文件Close #1 '关闭文本文件Next yActiveWorkbook.Close FalseNext xApplication.ScreenUpdating = TrueEnd Sub10，文本数据逐行导入（文本导入、不重复值、自定义格式、自定义条件格式）‘/dispbbs.asp?boardID=2&ID=247693&page=1&px=0‘要生成的GB－LOAD样式.xls （自编宏之三）Dim Myr%, x%, n%, r1, Myc%, aa, bb, res, y%Dim Sht1 As WorksheetDim Sht2 As WorksheetSub sujcl()' 数据处理' 蓝桥玄霜2007-6-20Application.ScreenUpdating = FalseSet Sht1 = Sheets(1)Set Sht2 = Sheets(2)Sht1.Activate[a1].SelectSht1.Cells.ClearContentsCall ImportRangen = 2Myr = [a65536].End(xlUp).RowColumns("A:A").SelectSelection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(9, 1), Array(23, 1)), TrailingMinusNumbers:= _TrueRange("A2:A" & Myr).SelectSelection.Cut Destination:=Range("A3:A" & Myr + 1)Call qukh ‘删除表1的空白行Call fuz0619 ‘复制数据到表2Application.ScreenUpdating = TrueEnd SubSub ImportRange()'引用自"VBA入门与实战"Dim cell As RangeDim Filename As StringDim x As Long, y As IntegerDim str As String, temp As StringDim Data As VariantDim i As IntegerOn Error Resume NextSet cell = ActiveCellFilename = ThisWorkbook.Path & "\GB LOAD.txt"Open Filename For Input As #1If Err <> 0 ThenMsgBox "无法找到" & Filename, vbCritical, "ERROR"Exit SubEnd Ifx = 0y = 0str = ""Application.ScreenUpdating = False '忽略屏幕刷新Do Until EOF(1)Line Input #1, DataFor i = 1 To Len(Data)temp = Mid(Data, i, 1)If temp = "," ThenActiveCell.Offset(x, y) = stry = y + 1str = ""ElseIf i = Len(Data) ThenIf temp <> Chr(34) Then str = str & tempActiveCell.Offset(x, y) = strstr = ""ElseIf temp <> Chr(34) Thenstr = str & tempEnd IfNext iy = 0x = x + 1LoopClose #1Application.ScreenUpdating = TrueEnd SubSub fuz0619()'复制' 蓝桥玄霜2007-6-20'Dim Myr%, x%, n%, r1, Myc%, aa, resDim Sht1 As WorksheetDim Sht2 As WorksheetApplication.ScreenUpdating = FalseSet Sht1 = Sheets(1)Set Sht2 = Sheets(2)n = 2Sht1.ActivateMyr = [a65536].End(xlUp).RowSht2.Activate[b1] = 1: [c1] = 2Range("b1:c1").AutoFill Range("b1:q1")Sht1.ActivateCall UniquedataFor y = 0 To bbFor x = 3 To Myr + 1If Sht1.Cells(x, 1) <> "" ThenIf Sht1.Cells(x, 1) = Sht1.Cells(y + 3, 8) ThenIf Sht1.Cells(x, 1) <> Sht1.Cells(x - 1, 1) ThenSht2.Cells(n, 1) = Cells(x, 1)End Ifaa = Cells(x, 2)Set r1 = Sht2.Range("a1:q1").Find(aa)If Not r1 Is Nothing ThenMyc = r1.ColumnSht2.Cells(n, Myc) = Cells(x, 3)End IfElseGoTo 100End IfEnd If100:Next xn = n + 1Next ySht2.ActivateMyr = [a65536].End(xlUp).RowRange("b2:q" & Myr).SelectSelection.NumberFormatLocal = "0%"Selection.FormatConditions.DeleteSelection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreater, _ Formula1:="0.8"Selection.FormatConditions(1).Interior.ColorIndex = 3Application.ScreenUpdating = TrueEnd SubSub Uniquedata()'不重复值'引用自实战精粹Dim Cel As Range, d, i%Set d = CreateObject("Scripting.Dictionary")Set Sht1 = Sheets(1)n = 3Sht1.ActivateMyr = [a65536].End(xlUp).RowFor Each Cel In Sht1.Range("a3:a" & Myr)If Cel <> "" ThenIf Not d.exists(Cel.Value) Thend.Add Cel.Value, Cel.ValueEnd IfEnd IfNextres = d.Itemsbb = UBound(res)For x = 0 To bbCells(n, 8) = res(x)n = n + 1Next xEnd SubSub qukh()'去除表1空白行'2007/6/20Application.ScreenUpdating = FalseSet Sht1 = Sheets(1)Myr = [a65536].End(xlUp).RowFor x = 3 To MyrIf Left(Cells(x, 1), 1) <> "B" ThenCells(x, 1).EntireRow.Delete shift:=xlUpMyr = Myr - 1: x = x - 1If x > Myr Then Exit SubEnd IfNext xApplication.ScreenUpdating = TrueEnd Sub11，按日期段和条件导出数据，另存为文件‘/dispbbs.asp?boardID=5&ID=27397&page=1‘5550925.xls （自编宏之三）Option ExplicitDim x%, n1%Dim Sht1 As Worksheet, Sht As WorksheetSub daocu()Dim ksrq As Date, jsrq As DateDim ksnm$, jsnm$, n, nn, nmDim Myr%, arr1, y%, i%Dim sFilenm$Application.ScreenUpdating = FalseIf UserForm1.TextBox1.Value = "" Or UserForm1.TextBox2.V alue = "" Then Exit Sub Set Sht1 = Sheets("Sheet3")Sht1.ActivateRange(Cells(2, 1), Cells(2000, 26)).ClearContentsksrq = UserForm1.TextBox1.Valuejsrq = UserForm1.TextBox2.Valuen = DateDiff("m", ksrq, jsrq) + 1ksnm = Right(Year(ksrq), 2) & Application.WorksheetFunction.Text(Month(ksrq), "00") jsnm = Right(Year(jsrq), 2) & Application.WorksheetFunction.Text(Month(jsrq), "00") ReDim nn(1 To n)ReDim nm(1 To n)For i = 1 To nIf i = 1 Thennm(1) = ksnm: nn(1) = CInt(ksnm)Elsenn(i) = nn(i - 1) + 1If Right(nn(i), 2) = "13" Then nn(i) = nn(i) + 100 - 12nm(i) = Application.WorksheetFunction.Text(nn(i), "0000") End IfNext in1 = 2For i = 1 To UBound(nn)For Each Sht In SheetsIf = nm(i) ThenSht.ActivateMyr = [a65536].End(xlUp).RowFor x = 2 To MyrIf Cells(x, 2) >= ksrq And Cells(x, 2) <= jsrq ThenCall daocu1n1 = n1 + 1End IfNext xEnd IfNext ShtNext iSht1.ActivateApplication.ScreenUpdating = TrueSht1.CopysFilenm = Application.GetSaveAsFilename(filefilter:="Excel files (*.xls),*.xls") ActiveWorkbook.SaveAs sFilenm, xlTextMsgBox "数据已导出! "End SubSub daocu1()'选择导出Dim xx%For xx = 0 To 25If UserForm1.ListBox1.Selected(xx) = True ThenCells(x, xx + 1).Copy Sht1.Cells(n1, xx + 1)End IfNext xxEnd Sub12，导出到多文本文件Sub dcdwb()'导出到文本文件（自编宏之二）‘请赐教0608.xls‘/dispbbs.asp?boardID=2&ID=245438&page=1&px=0 '2007/6/8Dim Filename$, Data$, aa$,Mypa$Dim rows As Long, cols%Dim i%, j%, Myr%, rr%, add%, n%Dim cell As RangeApplication.ScreenUpdating = FalseMypa = ThisWorkbook.Path & "\"Myr = [b65536].End(xlUp).Row: n = 2Range("A1").SelectIf [a1] = "★" Then aa = [b1]Do Until ActiveCell.Row > MyrCells.Find(What:="★", After:=ActiveCell).Activaterr = ActiveCell.RowActiveCell.Offset(-rr + n, 1).Resize(rr - n, 1).SelectSet cell = Selection '选择数据cols = cell.Columns.Countrows = cell.rows.CountFilename = Mypa & aa & ".txt" ‘文件名Open Filename For Output As #1For i = 1 To rowsData = cell.Cells(i, cols) '一列数据If IsEmpty(cell.Cells(i, cols)) Then Data = ""Print #1, (Data) '字符串型可去除""Next iClose #1ActiveCell.Offset(rr - n, -1).Resize(1, 1).Selectaa = Cells(rr, 2).Text ‘文件名n = rr + 1LoopApplication.ScreenUpdating = TrueEnd SubSub dcdwb2()'导出到一个文本文件'水平数据'2007/6/8Dim Filename$, Data$, aa$, Mypa$Dim rows As Long, cols%, cols1%Dim i%, j%, Myr%, rr%, add%, n%Dim cell As RangeApplication.ScreenUpdating = FalseMypa = ThisWorkbook.Path & "\"Myr = [b65536].End(xlUp).Row: n = 2Range("A1").SelectIf [a1] = "★" Then aa = [b1]Filename = Mypa & aa & ".txt"Open Filename For Append As #1Do Until ActiveCell.Row > MyrCells.Find(What:="★", After:=ActiveCell).Activaterr = ActiveCell.RowActiveCell.Offset(-rr + n - 1, 1).Resize(rr - n + 1, 1).SelectSet cell = Selection '选择数据cols = cell.Columns.Countrows = cell.rows.CountSelection.CopyRange("H1").SelectSelection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _ , Transpose:=TrueApplication.CutCopyMode = Falsecols = cols + 7cols1 = rows + 7For i = cols To cols1Data = Cells(1, i) '一单元格的数据If IsEmpty(Cells(1, i)) Then Data = ""If i <> cols1 ThenPrint #1, (Data) & " "; '数据没有"",加空格（如果用Write #1,Data; 则文本中数据有””）ElsePrint #1, (Data)End IfNext iSelection.ClearContentsCells(rr, 1).Selectn = rr + 1LoopClose #1Application.ScreenUpdating = TrueEnd Sub‘/viewthread.php?tid=596265&pid=4001678&page=1&extra=page%3D 1Sub dcdwb()Dim Filename$, Data$, aa$, Mypa$, ArrDim rows As Long, col%Dim i%, j%, Myr%, rr%, nApplication.ScreenUpdating = FalseMypa = ThisWorkbook.Path & "\"Myr = [b65536].End(xlUp).RowArr = Range("a1:c" & Myr)For i = 1 To UBound(Arr) Step 4n = 0: col = col + 1Filename = Mypa & col & ".txt" '文件名Open Filename For Output As #1For rr = i To i + 4If rr > Myr Then Data = "" & vbTab & "" & vbTab & n: Print #1, (Data): Exit ForIf rr <> i + 4 ThenData = Arr(rr, 1) & vbTab & Arr(rr, 2) & vbTab & Arr(rr, 3)n = n + Arr(rr, 3)ElseData = "" & vbTab & "" & vbTab & nEnd IfPrint #1, (Data)NextClose #1NextApplication.ScreenUpdating = TrueEnd Sub13，导入文本文件（用文本文件名为新表命名）Sub Drwbwj()' 导入文本文件,用文本文件名为新表命名‘导入文本文件.xls （自编宏之一）' by:蓝桥玄霜' 2007-3-7‘/dispbbs.asp?boardid=5&id=13592Dim Mystr As StringDim filename '文件路径'选取文件Application.ScreenUpdating = FalseOn Error GoTo 100Dofilename = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "请选择文件", , MultiSelect:=False)ActiveWorkbook.Worksheets.Add '把文本文件导入Excel新表"TEXT;" & filename, Destination:=Range("A1")).Refresh BackgroundQuery:=FalseEnd With[j2] = filename '以下为获取文件名，给新表命名[j3].SelectActiveCell.FormulaR1C1 = _"=RIGHT(R[-1]C,LEN(R[-1]C)-FIND(""/"",SUBSTITUTE(R[-1]C,""\"",""/"",LEN(R[-1]C)-LEN (SUBSTITUTE(R[-1]C,""\"","""")))))"[j4].SelectActiveCell.FormulaR1C1 = "=LEFT(R[-1]C,LEN(R[-1]C)-4)"Mystr = [j4]'MsgBox Mystr = MystrRange("j2:j4").ClearContents '删除辅助列Loop Until filename = FalseGoTo 200100:Application.DisplayAlerts = False ‘不使报警ActiveWindow.SelectedSheets.DeleteApplication.DisplayAlerts = True200:Application.ScreenUpdating = TrueEnd SubSub LxDrwbwj()' 连续导入文本文件‘导入后.xls' by:蓝桥玄霜' 2007-3-19Dim filename ‘文件路径Dim Myr1%, n%Application.ScreenUpdating = FalseOn Error GoTo 200ActiveWorkbook.Worksheets("Sheet1").Activate '激活表1n = 1Dofilename = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "请选取文件", , MultiSelect:=False) ‘选取文本文件"TEXT;" & filename, Destination:=Range("A" & n)).Refresh BackgroundQuery:=FalseIf n > 1 ThenRange("a" & n).EntireRow.Delete ‘第二个表头行删除End IfMyr1 = [a1].End(xlDown).Rown = Myr1 + 1End WithLoop Until filename = False200:Application.ScreenUpdating = TrueEnd Sub14，导出到文本文件‘2007314‘体彩3D分析.xls （自编宏之一）‘先选择要导出的数据Private Sub CommandButton1_Click()Dim Filename As StringDim rows As Long, cols As IntegerDim i As Long, j As IntegerDim Data As StringDim cell As RangeSet cell = Selection ‘选择数据cols = cell.Columns.Countrows = cell.rows.CountFilename = "G:\Excel论坛\精英培训\数据0313.txt"Open Filename For Output As #1For i = 1 To rowsData = cell.Cells(i, cols) ‘一列数据If IsEmpty(cell.Cells(i, cols)) Then Data = ""Print #1, (Data) ‘字符串型可去除””‘如果用Write #1 Data，输出的是”200365”Next iClose #1End Sub15，导出指定区域数据到文本文件，路径可选择（GetSaveAsFilename）‘/dispbbs.asp?boardID=2&ID=316431&page=1&px=0Private Sub CommandButton1_Click()Dim Filename As StringDim rows As Long, cols As IntegerDim i As Long, j%Dim Data As StringDim cell As RangeSet cell = Selection '选择数据cols = cell.Columns.Countrows = cell.rows.Count‘Filename = Application.GetSaveAsFilename("Text files (*.txt),*.txt")DoFilename = Application.GetSaveAsFilenameLoop Until Filename <> FalseOpen Filename For Output As #1For i = 1 To rowsFor j = 1 To colsData = cell.Cells(i, j) & " "If j = cols Then Print #1, (Data): GoTo 100Print #1, (Data);Next j100:Next iClose #1End Sub16，导入指定文件夹的文本文件（包括子文件夹），用文本文件名为新表命名，FileSearch，分列Sub pldrwb0423()‘inandout.xls EP'批量导入指定文件夹文本文件Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As LongSet myFs = Application.FileSearchmyPath = ThisWorkbook.Path & "\source\" '你的文本文件夹With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.txt".SearchSubFolders = True '同时也搜索子文件夹If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)Filename = myfile(i)aa = InStrRev(Filename, "\")nm = Right(Filename, Len(Filename) - aa)nm = Left(nm, Len(nm) - 4)ActiveWorkbook.Worksheets.Add '把文本文件导入Excel新表With ActiveSheet.QueryTables.Add(Connection:= _"TEXT;" & Filename, Destination:=Range("A1")).Refresh BackgroundQuery:=FalseEnd With = nmColumns("A:A").SelectSelection.TextToColumns Destination:=Range("A1"), Space:=True, FieldInfo _:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True[a1].SelectNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSet myFs = NothingEnd Sub17，批量删除同文件夹里指定工作簿文件，‘/dispbbs.asp?boardid=5&id=87719&star=1#1101674Sub plsc0119()'批量删除指定的文件Dim myFs As FileSearchDim myPath As String, Filename$Dim i As Long, n As Long, myFileSet myFs = Application.FileSearchmyPath = ThisWorkbook.Path '你的文本文件夹With myFs.NewSearch.LookIn = myPath.FileType = msoFileTypeNoteItem.Filename = "*.xls"If .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountReDim myFile(1 To n) As StringFor i = 1 To nmyFile(i) = .FoundFiles(i)If InStr(myFile(i), "一月") > 0 Or InStr(myFile(i), "二月") > 0 Or InStr(myFile(i), "三月") > 0 ThenKill myFile(i)End IfNextEnd IfEnd WithEnd Sub18，统计文件夹里子文件夹名及所有的文件名‘/viewthread.php?tid=393673&page=1&extra=page%3D1‘示例.rarSub wjjm()'文件夹名Dim fso, f, fc, myPath$, i%, myFolSet fso = CreateObject("Scripting.FileSystemObject")myPath = ThisWorkbook.pathSet f = fso.GetFolder(myPath)Set fc = f.SubFoldersFor Each myFol In fci = i + 1Cells(i, 1) = NextSet fso = NothingEnd SubSub wjjm()'同目录下文件名（Files对象）Dim fso, f, fc, myPath$, i%, myFolSet fso = CreateObject("Scripting.FileSystemObject")myPath = ThisWorkbook.PathSet f = fso.GetFolder(myPath)Set fc = f.FilesFor Each myFol In fcIf Right(, 3) = "xls" Theni = i + 1Cells(i, 1) = End IfNextSet fso = NothingEnd Sub19，对文件夹里没有后缀名的文件加”.txt”后缀‘2009-5-4 EPSub tjwjjwj()'统计文件夹文件Dim myFs As FileSearchDim myPath As StringDim i As Long, n As LongSet myFs = Application.FileSearchmyPath = ThisWorkbook.pathWith myFs.NewSearch.LookIn = myPath.SearchSubFolders = TrueIf .Execute(SortBy:=msoSortByFileName) > 0 Thenn = .FoundFiles.CountMsgBox "该文件夹里有" & n & "个文件"ReDim myfile(1 To n) As StringFor i = 1 To nmyfile(i) = .FoundFiles(i)aa = InStrRev(myfile(i), "\")nm = Right(Myfile(i), Len(Myfile(i)) - aa)‘nm = Left(nm, Len(nm) - 4)Cells(i, 1) = nmNextElseMsgBox "该文件夹里没有任何文件"End IfEnd WithSet myFs = Nothing。