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

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), …… 此处隐藏：378字，全部文档内容请下载后查看。喜欢就下载吧 ……