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

rmb = rmb + Val(Left(b, Len(b) - n)) End If End If Next Close #1

MsgBox \的金币是： \元\人民币是： \元\

End Sub

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

‘Book1.xls Sub tqwb()

Dim a() As String, b() As String, i&, rq, y& Dim Arr, myPath$, myName$ Dim Myc%, Myr&, Arr1, j&

Application.ScreenUpdating = False On Error GoTo 100

Myr = [a65536].End(xlUp).Row Myc = [iv1].End(xlToLeft).Column Arr = Range(\

Arr1 = Range(\myPath = ThisWorkbook.Path & \For y = 1 To 11

myName = Arr(y, 1) & \

Open ThisWorkbook.Path & \ a = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) For j = 3 To Myc Step 2

rq = Format(Cells(1, j).Value, \ For i = 0 To UBound(a)

If InStr(a(i), rq) > 0 Then b = Split(a(i), vbTab) Arr1(y, j - 2) = b(1) Arr1(y, j - 1) = b(4) Exit For End If Next Next Close #1 Next 100:

[c4].Resize(UBound(Arr1), UBound(Arr1, 2)) = Arr1 Application.ScreenUpdating = True End Sub

27，将文本文件读入

‘2010-2-4

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

Sub Macro2()

Application.DisplayAlerts = False Dim Myflnm$

Myflnm = ThisWorkbook.Path & \自选股.txt\

Workbooks.OpenText Filename:=Myflnm, Origin:=936, _

StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _

ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _ , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 1), _

Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), _ Array(10, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array( _

16, 1), Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), _

Array(23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array( _

29, 1), Array(30, 1), Array(31, 1)), TrailingMinusNumbers:=True [a1].CurrentRegion.Copy ActiveWorkbook.Close ThisWorkbook.Activate [a1].Select

ActiveSheet.Paste [a1].Select

Application.DisplayAlerts = True End Sub

28，按需要的行将文本文件读入

‘2010-2-5

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub

If Target.Address <> \

Dim a() As String, b() As String, i&, nm$, Myr&, Arr nm = Target.Value

Myr = [d65536].End(xlUp).Row Arr = Range(\

Open ThisWorkbook.Path & \a = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) For i = 1 To UBound(Arr) b = Split(a(i - 1), vbTab)

Cells(i + 2, 5).Resize(1, UBound(b) + 1) = b Next Close #1 End Sub

29，将多个文本文件读入

‘http://www.excelpx.com/dispbbs.asp?boardID=5&ID=126316&page=1 ‘整理后0423.xls Sub tqwb()

Dim a() As String, Arr1, i&, m%, r1, Arr(1 To 1, 1 To 11) Dim MyPath$, MyName$

MyPath = ThisWorkbook.Path & \整理前\\\MyName = Dir(MyPath & \Sheet1.[a2:k10000].ClearContents m = 1

Do While MyName <> \

Open MyPath & MyName For Input As #1

a = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf) Sheet2.[a1:f20].ClearContents

Sheet2.[a1].Resize(UBound(a) + 1, 1) = Application.Transpose(a) Call yy

Arr1 = Sheet2.[a1:f15] For i = 1 To 15 Select Case i Case 1

Arr(1, 1) = Arr1(1, 2) Case 4

Arr(1, 2) = Arr1(4, 3) Case 6, 5

Arr(1, i - 2) = Arr1(i, 4) Case 8, 12, 11

Arr(1, i - 3) = Arr1(i, 4) Case 9, 10

Arr(1, i - 3) = Arr1(i, 3) Case 14

Arr(1, 10) = Arr1(i, 4) Case 15

Arr(1, 11) = Arr1(i, 3) End Select Next 100: Close #1 m = m + 1

Sheet1.Cells(m, 1).Resize(1, 11) = Arr MyName = Dir Loop

Sheet2.[a1:f20].ClearContents End Sub

Sub yy()

Application.DisplayAlerts = False

Sheet2.Range(\Destination:=Range(\DataType:=xlDelimited, _

TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _ Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _

:=Array(Array(1, 1), Array(2, 2), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _ TrailingMinusNumbers:=True ‘Array(2, 2)中参数为第2列按文本格式 Application.DisplayAlerts = True End Sub

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

‘book1.xls ‘2010-5-21 Sub wbwj()

Dim a() As String, Arr1(), i&, r%, nm, bb Dim MyPath$, MyName$

MyPath = ThisWorkbook.Path & \MyName = Dir(MyPath & \Sheet2.[a1:d1000].ClearContents Do While MyName <> \

nm = Split(MyName, \

Open MyPath & MyName For Input As #1

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

ReDim Preserve Arr1(1 To 4, 1 To r) Arr1(1, r) = nm(4)

Arr1(2, r) = Left(nm(5), Len(nm(5)) - 4)

Arr1(3, r) = Left(bb(23), 10) Arr1(4, r) = Right(bb(26), 1) End If Next Close #1

MyName = Dir Loop

Sheet2.[a1].Resize(r, 4) = Application.Transpose(Arr1) End Sub …… 此处隐藏：455字，全部文档内容请下载后查看。喜欢就下载吧 ……