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

ks = Arr1(j) + 1

Workbooks.Open pa1 & \ Dim wb As Workbook Set wb = ActiveWorkbook For Each sh In Sheets For ii = ks To js

If sh.Name = Arr(ii, 3) Then sh.Name = Arr(ii, 5) Exit For End If Next Next

wb.Close savechanges:=True Set wb = Nothing Next

Application.DisplayAlerts = True End Sub

24，多工作簿提取数据（by:zhaogang1960）

‘http://club.excelhome.net/thread-509610-1-1.html ‘汇总.xls Sub Macro1()

Dim MyPath$, MyName$, sh As Worksheet Dim arr, brr(), d As Object, lr&, i&, m% Set sh = ActiveSheet

lr = Range(\ arr = Range(\

Set d = CreateObject(\ For i = 1 To lr - 1 d(arr(i, 1)) = i Next

MyPath = ThisWorkbook.Path & \明细\\\ MyName = Dir(MyPath & \ Application.ScreenUpdating = False

sh.UsedRange.Offset(0, 1).ClearContents Do While MyName <> \ m = m + 1

With GetObject(MyPath & MyName)

arr = .Sheets(1).Range(\ .Close False End With

sh.Cells(1, m + 1) = Left(MyName, Len(MyName) - 4) ReDim Preserve brr(1 To lr - 1, 1 To m) For i = 2 To UBound(arr)

If d.Exists(arr(i, 1)) Then brr(d(arr(i, 1)), m) = arr(i, 2) Next

MyName = Dir Loop

Range(\ Application.ScreenUpdating = True MsgBox \完毕\End Sub

25，多工作簿另存（FileSearch）

‘http://club.excelhome.net/viewthread.php?tid=507778&pid=3385765&page=1&extra=page=1

Sub dgzblc()

'多工作簿另存

'by:蓝桥 2009-12-17 Dim myFs As FileSearch

Dim myPath As String, Filename$ Dim i&, n&, nm$, myfile Dim wb1 As Workbook

Dim nm1$, bb$, aa$, newflnm$ Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next nm = \汇总成绩表\

Set wb1 = ThisWorkbook

Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = nm & \ .SearchSubFolders = True

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

ReDim myfile(1 To n) As String For i = 1 To n

myfile(i) = .FoundFiles(1) Filename = myfile(i)

aa = InStrRev(Filename, \ bb = Left(Filename, aa - 1) aa = InStrRev(bb, \

nm1 = Right(bb, Len(bb) - aa) nm1 = Right(nm1, Len(nm1) - 3) Stop

newflnm = myPath & \ Workbooks.Open myfile(i) Dim wb As Workbook

wb.SaveAs Filename:=newflnm wb.Close savechanges:=False Set wb = Nothing Next End If End With

Set myFs = Nothing

Application.DisplayAlerts = True Application.ScreenUpdating = True

End Sub

26，将文本文件读入数组

‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=110328&star=1#1418169 ’15.xls Sub tqwb()

Dim a() As String, b() As String, i&, rq, r1

Open ThisWorkbook.Path & \

a = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) For i = 0 To UBound(a) If a(i) <> \ b = Split(a(i))

rq = Val(Left(b(0), 2)) & \日\ Set r1 = Sheet1.[a:a].Find(rq, , , 1) If InStr(a(i), \ If Not r1 Is Nothing Then Cells(r1.Row, 3) = b(1) End If Else

Cells(r1.Row, 2) = b(1) End If End If Next Close #1 End Sub

‘http://club.excelhome.net/viewthread.php?tid=529795&pid=3496119&page=1&extra=page=1

Sub tqwb()

Dim a() As String, b$, i&, jb, rmb, n%

Open ThisWorkbook.Path & \需要统计数据.txt\ a = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) jb = 0: rmb = 0

For i = 0 To UBound(a) - 4 Step 4

If InStr(a(i + 1), \ If InStr(a(i + 2), \金币\ b = Split(a(i + 2), \金币=\ n = InStr(b, \元\

jb = jb + Val(Left(b, Len(b) - n)) ElseIf InStr(a(i + 2), \人民币\ b = Split(a(i + 2), \人民币=\ n = InStr(b, \元\