第9章--文件操作代码【超实用VBA】

1、第9章 文件操作范例134 导入文本文件134-1 使用查询表导入Sub AddQuery() With Sheet2 .UsedRange.ClearContents With .QueryTables.Add(Connection:="TEXT;" & ThisWorkbook.Path & "工资表.txt", Destination:=.Range("A1") .TextFileCommaDelimiter = True .Refresh End With .Select End WithEnd Sub134-

2、2 使用Open 语句导入Sub OpenText() Dim MyText As String Dim MyArr() As String Dim c As Integer Dim r As Integer r = 1 With Sheet2 .UsedRange.ClearContents Open ThisWorkbook.Path & "工资表.txt" For Input As #1 Do While Not EOF(1) Line Input #1, MyText MyArr = Split(MyText, ",") For c =

3、0 To UBound(MyArr) .Cells(r, c + 1) = MyArr(c) Next r = r + 1 Loop Close #1 .Select End WithEnd Sub134-3 使用OpenText方法Sub OpenText() Sheet2.UsedRange.ClearContents Workbooks.OpenText Filename:=ThisWorkbook.Path & "" & "工资表.txt", StartRow:=1, DataType:=xlDelimited, Comma:=T

4、rue With ActiveWorkbook With .Sheets("工资表").Range("A1").CurrentRegion ThisWorkbook.Sheets("Sheet2").Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value End With .Close False End With Sheet2.SelectEnd Sub范例135 将数据写入文本文件135-1 使用Print # 语句Sub PrintText

5、() Dim File As String Dim Arr() As Variant Dim Str As String Dim r As Integer Dim c As Integer Dim i As Integer Dim j As Integer On Error Resume Next File = ThisWorkbook.Path & "" & "工资表.txt" Kill File With Sheet2 r = .UsedRange.Rows.Count c = .UsedRange.Columns.Count ReD

6、im Arr(1 To r, 1 To c) For i = 1 To r For j = 1 To c Arr(i, j) = .Cells(i, j).Value Next Next End With Open File For Output As #1 For i = 1 To UBound(Arr, 1) Str = "" For j = 1 To UBound(Arr, 2) Str = Str & CStr(Arr(i, j) & "," Next Str = Left(Str, (Len(Str) - 1) Print #1

7、, Str Next Close #1 MsgBox "文件保存成功!"End Sub135-2 使用SaveAs方法Sub SaveText() Dim File As String File = ThisWorkbook.Path & "工资表.txt" On Error Resume Next Kill File Sheet2.Copy ActiveWorkbook.SaveAs FileName:=File, FileFormat:=xlCSV ActiveWorkbook.Close SaveChanges:=False MsgBox

8、"文件保存成功!"End Sub范例136 获得文件修改的日期和时间Sub MyDateTime() Dim Str As String Str = ThisWorkbook.Path & "" & ThisWorkbook.Name MsgBox Str & "的最后修改时间是：" & Chr(13) & FileDateTime(Str)End Sub范例137 查找文件和文件夹Sub MyName() Dim MyName As String Dim r As Integer r = 1

9、Columns("A").ClearContents MyName = Dir(ThisWorkbook.Path & "", vbDirectory) Do While MyName <> "" If MyName <> "." And MyName <> "." Then Cells(r, 1) = MyName r = r + 1 End If MyName = Dir LoopEnd Sub范例138 获得当前文件夹Sub CurFolder(

10、) MsgBox CurDir("D")End Sub范例139 创建和删除文件夹Sub CreateFolder() On Error Resume Next MkDir ThisWorkbook.Path & "Temp"End SubSub DeleteFolder() On Error Resume Next RmDir ThisWorkbook.Path & "Temp"End Sub范例140 重命名文件或文件夹Sub RenameFiles() Dim MyPath As String On Error

11、Resume Next MyPath = ThisWorkbook.Path Name MyPath & "123" As MyPath & "ABC" Name MyPath & "123.xlsx" As MyPath & "ABCABC.xlsx"End Sub范例141 复制指定的文件Sub CopyingFiles() Dim SourceFile As String Dim DestinationFile As String SourceFile = ThisWorkbo

12、ok.Path & "123.xlsx" DestinationFile = ThisWorkbook.Path & "ABCabc.xlsx" FileCopy SourceFile, DestinationFileEnd Sub范例142 删除指定的文件Sub DeleteFiles() Dim myFile As String myFile = ThisWorkbook.Path & "123.xlsx" If Dir(myFile) <> "" Then Kill myF

13、ileEnd Sub范例143 使用WSH处理文件143-1 获取文件信息Sub FileInformation() Dim MyFile As Object Dim Str As String Dim StrMsg As String Str = ThisWorkbook.Path & "123.xlsx" Set MyFile = CreateObject("Scripting.FileSystemObject") With MyFile.Getfile(Str) StrMsg = StrMsg & "文件名称："

14、 & .Name & Chr(13) _ & "文件创建日期：" & .DateCreated & Chr(13) _ & "文件修改日期：" & .DateLastModified & Chr(13) _ & "文件访问日期：" & .DateLastAccessed & Chr(13) _ & "文件保存路径：" & .ParentFolder End With MsgBox StrMsg Set MyFil

15、e = NothingEnd Sub143-2 取得文件基本名Sub FileBaseName() Dim MyFile As Object Dim FileName As Variant Set MyFile = CreateObject("Scripting.FileSystemObject") FileName = Application.GetOpenFilename If FileName <> "False" Then MsgBox MyFile.GetBaseName(FileName) End If Set MyFile =

16、NothingEnd Sub143-3 查找文件Sub FindFiles() Dim MyFile As Object Dim Str As String Str = ThisWorkbook.Path & "123.xlsx" Set MyFile = CreateObject("Scripting.FileSystemObject") If Not MyFile.FileExists(Str) Then MsgBox "文件不存在!" Else MsgBox "文件已找到!" End If Set M

17、yFile = NothingEnd Sub143-4 搜索文件Sub SearchFiles() Dim MyFile As Object Dim MyFiles As Object Dim MyStr As String Set MyFile = CreateObject("Scripting.FileSystemObject") _ .Getfolder(ThisWorkbook.Path) For Each MyFiles In MyFile.Files If InStr(MyFiles.Name, ".xlsx") <> 0 The

18、n MyStr = MyStr & MyFiles.Name & Chr(13) End If Next MsgBox MyStr Set MyFile = Nothing Set MyFiles = NothingEnd Sub143-5 移动文件Sub MovingFiles() Dim MyFile As Object On Error Resume Next Set MyFile = CreateObject("Scripting.FileSystemObject") MyFile.MoveFile ThisWorkbook.Path & &

19、quot;123.xlsx", ThisWorkbook.Path & "abc" Set MyFile = NothingEnd Sub143-6 复制文件Sub CopyingFiles() Dim MyFile As Object On Error Resume Next Set MyFile = CreateObject("Scripting.FileSystemObject") MyFile.CopyFile ThisWorkbook.Path & "123.xlsx", ThisWorkbook.

20、Path & "abc" Set MyFile = NothingEnd Sub143-7 删除文件Sub DeleteFiles() Dim MyFile As Object On Error Resume Next Set MyFile = CreateObject("Scripting.FileSystemObject") MyFile.DeleteFile ThisWorkbook.Path & "123.xlsx" Set MyFile = NothingEnd Sub143-8 创建文件夹Sub Creat

21、eFolder() Dim MyFile As Object On Error Resume Next Set MyFile = CreateObject("Scripting.FileSystemObject") MyFile.CreateFolder (ThisWorkbook.Path & "abc") Set MyFile = NothingEnd Sub143-9 复制文件夹Sub CopyFolder() Dim MyFile As Object Set MyFile = CreateObject("Scripting.Fi

22、leSystemObject") MyFile.CopyFolder ThisWorkbook.Path & "ABC", ThisWorkbook.Path & "123" Set MyFile = NothingEnd Sub143-10 移动文件夹Sub MoveFolders() Dim MyFile As Object On Error Resume Next Set MyFile = CreateObject("Scripting.FileSystemObject") MyFile.MoveFol

23、der ThisWorkbook.Path & "123", ThisWorkbook.Path & "abc" Set MyFile = NothingEnd Sub143-11 删除文件夹Sub DeleteFolders() Dim MyFile As Object On Error Resume Next Set MyFile = CreateObject("Scripting.FileSystemObject") MyFile.DeleteFolder ThisWorkbook.Path & &quo

24、t;123" Set MyFile = NothingEnd Sub143-12 导入文本文件Sub ImportingText() Dim MyFile As Object Dim Arr() As String Dim r As Integer Dim i As Integer r = 1 Sheet2.UsedRange.ClearContents Set MyFile = CreateObject("Scripting.FileSystemObject") _ .OpenTextFile(ThisWorkbook.Path & "&quo

25、t; & "工资表.txt") Do While Not MyFile.AtEndOfStream Arr = Split(MyFile.ReadLine, ",") For i = 0 To UBound(Arr) Sheet2.Cells(r, i + 1) = Arr(i) Next r = r + 1 Loop MyFile.Close Sheet2.Select Set MyFile = NothingEnd Sub143-13 创建文本文件Sub CreateTtextFile() Dim MyFile As Object Dim M

26、yStr As String Dim r As Integer Dim c As Integer With Sheet2 Set MyFile = CreateObject("Scripting.FileSystemObject") _ .CreateTextFile(ThisWorkbook.Path & "工资表.txt", True) For r = 1 To .UsedRange.Rows.Count MyStr = "" For c = 1 To .UsedRange.Columns.Count MyStr = My

27、Str & .Cells(r, c) & "," Next MyStr = Left(MyStr, (Len(MyStr) - 1) MyFile.WriteLine (MyStr) Next MyFile.Close End With Set MyFile = NothingEnd SubSub CreateTtextFiles() Dim MyFile As Object Dim MyStr As String Dim r As Integer Dim c As Integer With Sheet2 Set MyFile = CreateObject("Scripting.FileSystemObject") _ .OpenTextFile(ThisWorkbook.Path & "" & "工资表.txt", 2, True) For r = 1 To .UsedRange.Rows.Count MyStr = "" For c = 1 To .UsedRange.Columns.Count MyStr =