1，导入文本数据（QueryTables）
‘110419.xls Sub daorwb() ' 2008-4-19
Columns(\
‘文本文件名放在[y2]单元格，两文件在同一个文件夹 With ActiveSheet.QueryTables.Add(Connection:= _
\ .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 With End Sub
2，从文本文件中复制部分数据（OpenText方法）
‘http://www.excelpx.com/dispbbs.asp?BoardID=92&ID=28958&replyID=&skin=1 Sub Macro1()
' 2007-10-18 （自编宏之四） '从文本文件中复制部分数据 ‘Book1017.xls+test1017.txt
Application.DisplayAlerts = False Dim Myflnm$
Myflnm = ThisWorkbook.Path & \ 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(\ ActiveWorkbook.Close
Application.DisplayAlerts = True End Sub
3，超链接自动生成（Hyperlink公式中引用单元格）
Sub caolj1108()
‘超链接1108.xls （自编宏之四） Dim Myr%, aa$, x%
Myr = [a65536].End(xlUp).Row For x = 4 To Myr - 3 aa = Cells(x, 1)
If aa <> \小\月\ Cells(x, \= \&\ ‘辅助列公式
Cells(x, \生產通知單類\\2007生產通知單\\\生產進度明細表.xls\進度明細表\
Cells(x, \生產通知單類\\2007生產通知單\\\生產通知單.xls\
Cells(x, \生產通知單類\\2007生產通知單\\\ End If Next x End Sub
4，批量插入指定文件夹图片（FileSearch 函数）
Sub plcrtp1111()（自编宏之四） '批量插入指定文件夹图片
Dim myFs As FileSearch Dim myPath As String Dim i As Long, n As Long
Set myFs = Application.FileSearch
myPath = \ '你的图片文件夹 With myFs
.NewSearch
.LookIn = myPath
.FileType = msoFileTypePhotoDrawFiles .Filename = \
If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count
MsgBox \该文件夹里有\个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 Macro1 End Sub
Sub 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 x End Sub
5，查询指定文件夹图片（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 <> \
myPath = \论坛数据\\Excel论坛\\未完成\\相片\\\ '你的图片文件夹 aa = myPath & [d2] & \ Cells(2, 6).Select
ActiveSheet.Pictures.Insert (aa) End Sub
6，导出N列数据到文本文件
http://club.excelhome.net/dispbbs.asp?BoardID=2&ID=280260&replyID=&skin=0 ‘求修改代码.xls （自编宏之四） Sub 导出N列数据() Dim Filename As String
Dim rows As Long, cols As Integer Dim i As Long, j As Integer Dim Data As Variant Dim cell As Range
Dim Arr, T, x%, fname$, fdir, N% fdir = ThisWorkbook.Path & \号码\N = 7
Filename = fdir & \Range(\Range(\Range(\Range(\Range(\Set cell = Selection
cols = cell.Columns.Count rows = cell.rows.Count
Open Filename For Output As #1 For 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 j Next i Close #1
Range(\End Sub
7，同文件夹根据文本数据修改（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(\
Selection.TextToColumns Destination:=Range(\ FieldInfo:=Array(Array(0, 1), Array(3, 1)), TrailingMinusNumbers:=True
Selection.CurrentRegion.Copy ThisWorkbook.Activate [a1].Select
ActiveSheet.Paste
Windows(\目录.txt\ ActiveWorkbook.Close
Myr = [a65536].End(xlUp).Row Arr = Range(\ For x = 1 To Myr
aa = Format(Arr(x, 1), \ bb = Trim(Arr(x, 2))
OldName = ThisWorkbook.Path & \ '原文件名 NewName = ThisWorkbook.Path & \ '新文件名 Name OldName As NewName '在同一个文件夹更改文件名 Next x
Application.DisplayAlerts = True End Sub
Excel VBA - 文本文件和文件夹操作实例集锦
