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

For i = 1 To 63

t(i) = Right(t(i \\ 2) & i Mod 2, 6) Next

Set dic = CreateObject(\ '创建字典

Open \ '读入数据到数组s s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) Close #1

For i = 0 To UBound(s)

If s(i) = \ v = Split(s(i)) For j = 1 To 63 temp = \ For k = 1 To 6

If Mid(t(j), k, 1) > 0 Then temp = temp & \ Next

temp = Trim(temp)

dic(temp) = dic(temp) + 1 Next Next

ReDim s(dic.Count, 1 To 3) s(0, 1) = \数字个数\ s(0, 2) = \组合\ s(0, 3) = \出现次数\

For Each d In dic.keys n = n + 1

s(n, 1) = (Len(d) + 1) / 3 s(n, 2) = d s(n, 3) = dic(d) Next

[a1].Resize(n + 1, 3) = s '排序

[a2].Resize(n, 3).Sort [b2], 1 [a2].Resize(n, 3).Sort [c2], 2 [a2].Resize(n, 3).Sort [a2], 1 Set dic = Nothing MsgBox \End Sub

22，多txt文件数据提取汇总

‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=101699&star=1#1305575

‘每日各机构支付清单.xls

Dim Filename$ Dim s, bb, cc Sub yy() Dim i&

Const aaa = \

Open Filename For Input As #1 '读入数据到数组s s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) For i = UBound(s) To 0 Step -1 If InStr(s(i), aaa) > 0 Then bb = Replace(s(i), aaa, \ bb = Application.Trim(bb) cc = Split(bb, \ Exit For End If Next Close #1 End Sub

Sub pldrsj1126()

'批量导入指定文件的数据

Dim myFs As FileSearch, myfile, ii&, Arr Dim myPath As String, ma&, mc&

Dim i As Long, n As Long, col&, aa$, nm$, nm1$ Dim Sht1 As Worksheet, r1

Application.ScreenUpdating = False Set Sht1 = ActiveSheet Sht1.[b5:i20] = \ Arr = Sht1.[b5:i20]

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path '指定的子文件夹内搜索 With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = \

.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(i) Filename = myfile(i)

If InStr(Filename, \

aa = InStrRev(Filename, \

nm = Right(Filename, Len(Filename) - aa) '文件名 nm1 = Mid$(nm, 6, 2) '机构名 Set r1 = Sht1.Range(\ If Not r1 Is Nothing Then n = r1.Row - 4 End If

If InStr(Filename, \工行\ col = 1

ElseIf InStr(Filename, \建行\ col = 5

ElseIf InStr(Filename, \农行\ col = 3

ElseIf InStr(Filename, \邮政\ col = 7 End If Call yy

Arr(n, col) = cc(0) Arr(n, col + 1) = cc(1) End If Next Else

MsgBox \该文件夹里没有任何文件\ End If End With

Sht1.[b5].Resize(UBound(Arr), UBound(Arr, 2)) = Arr Set myFs = Nothing

Application.ScreenUpdating = True End Sub

‘http://club.excelhome.net/viewthread.php?tid=508103&pid=3352236&page=2&extra= ‘批处理.xls

Public Filename$

Public aa1$, Arr1(1 To 4, 1 To 1) Sub yy()

Dim i&, a(1 To 3), n&, s For i = 1 To 4 Arr1(i, 1) = 0 Next

Open Filename For Input As #1 '读入数据到数组s s = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) a(1) = Left(aa1, 1) a(2) = Mid(aa1, 2, 1) a(3) = Right(aa1, 1)

For i = 0 To UBound(s) n = 0

If Left(s(i), 1) = a(1) Then n = n + 1 If Mid(s(i), 2, 1) = a(2) Then n = n + 1 If Right(s(i), 1) = a(3) Then n = n + 1 If n = 0 Then

Arr1(4, 1) = Arr1(4, 1) + 1 ElseIf n = 1 Then

Arr1(3, 1) = Arr1(3, 1) + 1 ElseIf n = 2 Then

Arr1(2, 1) = Arr1(2, 1) + 1 ElseIf n = 3 Then

Arr1(1, 1) = Arr1(1, 1) + 1 End If Next Close #1 End Sub

Sub pldrsj1204()

'批量导入指定文件的数据

Dim myFs As FileSearch, myfile, ii&, Arr, j&, aaa Dim myPath$, Myr&, jgnm Dim i&, n&, aa$, nm$, nm1$ Dim Sht1 As Worksheet, r1

Application.ScreenUpdating = False Set Sht1 = ActiveSheet

Myr = Sht1.[a65536].End(xlUp).Row Arr = Sht1.Range(\ Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path & \ '指定的子文件夹内搜索 With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = \

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

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

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

aa = InStrRev(Filename, \

nm = Right(Filename, Len(Filename) - aa) '文件名 nm1 = Val(Left$(nm, Len(nm) - 4))

If nm1 = j Then aa1 = Arr(j, 1) Call yy

aaa = aaa & j & \中3:\中2:\& \中1:\中0:\ Erase Arr1 Exit For End If Next Next Else

MsgBox \该文件夹里没有任何文件\ End If End With

jgnm = ThisWorkbook. …… 此处隐藏：469字，全部文档内容请下载后查看。喜欢就下载吧 ……