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

精品文档1，导入文本数据（QueryTables）110419.xlsSub daorwb() 2008-4-19 Columns(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:=False End WithEnd Sub 2，从文本文件中复制部分数据（OpenText方法）/dispbbs.asp?BoardID=92&ID=28958&replyID=&skin=1Sub Macro1() 2007-10-18 （自编宏之四）从文本文件中复制部分数据Book1017.xls+test1017.txt Application.DisplayAlerts = False Dim 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:=True Selection.CurrentRegion.Copy ThisWorkbook.Activate a1.Select ActiveSheet.Paste Windows(test1017.txt).Activate ActiveWorkbook.Close Application.DisplayAlerts = TrueEnd Sub3，超链接自动生成（Hyperlink公式中引用单元格）Sub caolj1108()超链接1108.xls （自编宏之四）Dim Myr%, aa$, x%Myr = a65536.End(xlUp).RowFor x = 4 To Myr - 3 aa = Cells(x, 1) If aa And InStr(aa, 小) = 0 And InStr(aa, 月) = 0 Then Cells(x, n).Formula = =if(-(right(rc-13,2) 0 Then n = .FoundFiles.Count MsgBox 该文件夹里有 & n & 个jpg文件 ReDim myfile(1 To n) As String For i = 1 To n myfile(i) = .FoundFiles(i) Cells(i, 1) = myfile(i) Next Else MsgBox 该文件夹里没有任何文件 End If End With Set myFs = Nothing Call Macro1End SubSub Macro1() Dim Myr%, x%, aa$ Myr = a65536.End(xlUp).Row For x = 1 To Myr aa = Cells(x, 1) Cells(x, 2).Select ActiveSheet.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 String Myr = a65536.End(xlUp).Row If Target.Address $D$1 Then Exit Sub myPath = F:论坛数据Excel论坛未完成相片 你的图片文件夹 aa = myPath & d2 & .jpg Cells(2, 6).Select ActiveSheet.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) & .txtRange(g5:g1004).Copy am5Range(o5:o1004).Copy an5Range(t5:t1004).Copy ao5Range(z5:z1004).Copy ap5Range(am5:ap1004).SelectSet cell = Selectioncols = cell.Columns.Countrows = cell.rows.CountOpen Filename For Output As #1For i = 1 To rows For j = 1 To cols Data = cell.Cells(i, j).Value If IsEmpty(cell.Cells(i, j) Then Data = If j cols Then Write #1, Data; Else Write #1, Data End If Next jNext iClose #1Range(am5:ap1004).ClearContentsEnd Sub7，同文件夹根据文本数据修改（Opentext，分列，Name）Mybk1.xls(QQ) （自编宏之五）Sub 批量修改文件名()同文件夹根据文本文件数据修改08-02-16 Dim OldName As String, NewName As String Dim Myflnm$ Dim Myr%, x%, Arr, aa$, bb$ On Error Resume Next Application.DisplayAlerts = False Myflnm = 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:=True Columns(A:A).Select Selection.TextToColumns Destination:=Range(A1), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(3, 1), TrailingMinusNumbers:=True Selection.CurrentRegion.Copy ThisWorkbook.Activate a1.Select ActiveSheet.Paste Windows(目录.txt).Activate ActiveWorkbook.Close Myr = a65536.End(xlUp).Row Arr = Range(a1:b & Myr) For x = 1 To Myr aa = 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 x Application.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 rng If cel Then If Len(cel) 0 Then aa = Split(cel.Address, $)(1)取得列的字符 col = cel.Column Filename = Environ(USERPROFILE) & 桌面 & aa & .txt 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 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 Myrj f = Dir(Cells(x, j), vbDirectory) 判断文件夹是否已经存在 If f = Then MkDir (Cells(x, j) 如果不存在就建立Next xFor x = 5 To Myrc Sht1.Activate m = 0 wjnm = 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 wjnm Set Sht2 = ActiveWorkbook.Sheets(shtnm) Sht2.Activate For y = 5 To Myrh m = m + 1: col = Filename = Sht1.Cells(y, j) & wbnm & .txt Range(bh:bh).ClearContents Columns(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 Then col = col & temp 动态区域列号 End If Next y1 n = Cells(65536, col).End(xlUp).Row Range(Cells(1, bh), Cells(n, bh) = Range(Cells(1, col), Cells(n, col).Value Set rng = Range(Cells(1, bh), Cells(n, bh) Open Filename For Output As #1 For i = 1 To n data = Cells(i, bh).Value If data = Then GoTo 100 Print #1, data 按列排列数据100: Next i Close #1 Stop 如果不要暂停，在此行前面加 Next y ActiveWorkbook.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 Myrj f = Dir(Cells(x, j), vbDirectory) 判断文件夹是否已经存在 If f = Then MkDir (Cells(x, j) 如果不存在就建立Next xFor x = 5 To Myrc Sht1.Activate m = 0 wjnm = 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 wjnm Set Sht2 = ActiveWorkbook.Sheets(shtnm) Sht2.Activate For y = 5 To Myrh m = m + 1: col = Filename = Sht1.Cells(y, j) & wbnm & .txt Range(bh:bh).ClearContents Columns(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 Then col = col & temp 动态区域列号 End If Next y1 n = Cells(65536, col).End(xlUp).Row Range(Cells(1, bh), Cells(n, bh) = Range(Cells(1, col), Cells(n, col).Value Set 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, , ) Loop Do While InStr(ctxt, Chr(13) & Chr(10) & Chr(13) & Chr(10) 0 ctxt = Replace(ctxt, Chr(13) & Chr(10) & Chr(13) & Chr(10), Chr(13) & Chr(10) Loop Open Filename For Output As #1 Open cPath2(i, 1) & Replace(MyName, .xls, .txt) For Output As #1 打开文本文件 Print #1, ctxt 将数据一次写入文本文件 Close #1 关闭文本文件 Next y ActiveWorkbook.Close FalseNext xApplication.ScreenUpdating = TrueEnd Sub10，文本数据逐行导入（文本导入、不重复值、自定义格式、自定义条件格式）/dispbbs.asp?boardID=2&ID=247693&page=1&px=0要生成的GBLOAD样式.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.Activatea1.SelectSht1.Cells.ClearContentsCall ImportRangen = 2Myr = a65536.End(xlUp).Row Columns(A:A).Select Selection.TextToColumns Destination:=Range(A1), DataType:=xlFixedWidth, _ FieldInfo:=Array(Array(0, 1), Array(9, 1), Array(23, 1), TrailingMinusNumbers:= _ True Range(A2:A & Myr).Select Selection.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.txtOpen Filename For Input As #1If Err 0 Then MsgBox 无法找到 & Filename, vbCritical, ERROR Exit SubEnd Ifx = 0y = 0str = Application.ScreenUpdating = False 忽略屏幕刷新Do Until EOF(1) Line Input #1, Data For i = 1 To Len(Data) temp = Mid(Data, i, 1) If temp = , Then ActiveCell.Offset(x, y) = str y = y + 1 str = ElseIf i = Len(Data) Then If temp Chr(34) Then str = str & temp ActiveCell.Offset(x, y) = str str = ElseIf temp Chr(34) Then str = str & temp End If Next i y = 0 x = x + 1LoopClose #1Application.ScreenUpdating = TrueEnd SubSub fuz0619()复制 蓝桥玄霜 2007-6-20Dim 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.Activateb1 = 1: c1 = 2Range(b1:c1).AutoFill Range(b1:q1)Sht1.ActivateCall UniquedataFor y = 0 To bb For x = 3 To Myr + 1 If Sht1.Cells(x, 1) Then If Sht1.Cells(x, 1) = Sht1.Cells(y + 3, 8) Then If Sht1.Cells(x, 1) Sht1.Cells(x - 1, 1) Then Sht2.Cells(n, 1) = Cells(x, 1) End If aa = Cells(x, 2) Set r1 = Sht2.Range(a1:q1).Find(aa) If Not r1 Is Nothing Then Myc = r1.Column Sht2.Cells(n, Myc) = Cells(x, 3) End If Else GoTo 100 End If End If100: Next x n = n + 1Next y Sht2.Activate Myr = a65536.End(xlUp).Row Range(b2:q & Myr).Select Selection.NumberFormatLocal = 0% Selection.FormatConditions.Delete Selection.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 = 3 Sht1.Activate Myr = a65536.End(xlUp).Row For Each Cel In Sht1.Range(a3:a & Myr) If Cel Then If Not d.exists(Cel.Value) Then d.Add Cel.Value, Cel.Value End If End If Next res = d.Items bb = UBound(res) For x = 0 To bb Cells(n, 8) = res(x) n = n + 1 Next xEnd SubSub qukh()去除表1空白行2007/6/20Application.ScreenUpdating = FalseSet Sht1 = Sheets(1)Myr = a65536.End(xlUp).RowFor x = 3 To Myr If Left(Cells(x, 1), 1) B Then Cells(x, 1).EntireRow.Delete shift:=xlUp Myr = Myr - 1: x = x - 1 If x Myr Then Exit Sub End IfNext xApplication.ScreenUpdating = TrueEnd Sub11，按日期段和条件导出数据，另存为文件/dispbbs.asp?boardID=5&ID=27397&page=15550925.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.Value = Then Exit SubSet 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 n If i = 1 Then nm(1) = ksnm: nn(1) = CInt(ksnm) Else nn(i) = nn(i - 1) + 1 If Right(nn(i), 2) = 13 Then nn(i) = nn(i) + 100 - 12 nm(i) = Application.WorksheetFunction.Text(nn(i), 0000) End IfNext in1 = 2For i = 1 To UBound(nn) For Each Sht In Sheets If Sht.Name = nm(i) Then Sht.Activate Myr = a65536.End(xlUp).Row For x = 2 To Myr If Cells(x, 2) = ksrq And Cells(x, 2) Myr Cells.Find(What:=, After:=ActiveCell).Activate rr = ActiveCell.Row ActiveCell.Offset(-rr + n, 1).Resize(rr - n, 1).Select Set c