各位大大好：
小弟遇到一難題，不知如何解開。
小弟想由文字檔內取出指定資料，
現問題是小弟利用INSTR可找出指定字串number_special時，
再判斷下一列的字串ct101_No時取出數值為：17，也就是
要取出該字串的下一列的部份資料。語法上為
K>0時可判斷出下一列的位置。
小弟不想將文字檔先全部載列於
工作表內，再利用OFFSET方式可逹成。
而是否有其它方式可直接由文字檔的下一
列取出資料呢？
文字檔內的部份資料如下：
<div align="center" class="number_special">
<span id="Lotto649Control_history1_dlQuery_ctl01_No">17</span> </div>
</td>
Sub TEST()
'設定引用項目Microsoft Scripting Runtime
Dim myFso As Scripting.FileSystemObject
Dim myTxt As Scripting.TextStream
Dim myStr As String
Dim mStr$, mStr1$, nStr1$, nStr2$, nStr3$, nStr4$, nStr5$, nStr6$
Dim m%, m1%, m2%, mLen%, n%, n1%, n2%, n3%, n4%, n5%, n6%, s1%, s2%, s3%, s4%, s5%, s6%, s7%, s8%
Dim mSht As Worksheet
Dim mRng As Range
Dim mTmp$, mTmp1$, numSpecial$
Dim myFs As FileSearch
Dim mPath As String, mFilename$
Dim i As Long, k%
numSpecial = "number_special"
mStr = "DrawTerm"
mStr1 = "DDate"
nStr1 = "_No1"
nStr2 = "_No2"
nStr3 = "_No3"
nStr4 = "_No4"
nStr5 = "_No5"
nStr6 = "_No6"
Set mSht = Worksheets("temp")
With mSht
.Cells.Clear
Set mRng = .Range("a1:i2000")
With mRng
.NumberFormatLocal = "@"
End With
Set myFs = Application.FileSearch
mPath = "D:\TEMP\"
With myFs
.NewSearch
.LookIn = mPath
.FileType = msoFileTypeAllFiles
.Filename = ".txt"
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName) > 0 Then
For i = 1 To .FoundFiles.Count
mFilename = .FoundFiles(i)
Set myFso = CreateObject("Scripting.FileSystemObject")
Set myTxt = myFso.OpenTextFile(Filename:=mFilename, IOMode:=ForReading)
s1 = mSht.[a65536].End(xlUp).Offset(1).Row
s2 = mSht.[b65536].End(xlUp).Offset(1).Row
s3 = mSht.[c65536].End(xlUp).Offset(1).Row
s4 = mSht.[d65536].End(xlUp).Offset(1).Row
s5 = mSht.[e65536].End(xlUp).Offset(1).Row
s6 = mSht.[f65536].End(xlUp).Offset(1).Row
s7 = mSht.[g65536].End(xlUp).Offset(1).Row
s8 = mSht.[h65536].End(xlUp).Offset(1).Row
With myTxt
Do Until .AtEndOfStream
myStr = Trim(.ReadLine)
If myStr <> "" Then
m = InStr(1, myStr, mStr, vbTextCompare)
m1 = InStr(1, myStr, mStr1, vbTextCompare)
n1 = InStr(1, myStr, nStr1, vbTextCompare)
n2 = InStr(1, myStr, nStr2, vbTextCompare)
n3 = InStr(1, myStr, nStr3, vbTextCompare)
n4 = InStr(1, myStr, nStr4, vbTextCompare)
n5 = InStr(1, myStr, nStr5, vbTextCompare)
n6 = InStr(1, myStr, nStr6, vbTextCompare)
k = InStr(1, myStr, numSpecial, vbTextCompare) '如果k>0時要取出下一列的數值資料
If m > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, m + 10, 9)
If IsNumeric(mTmp) Then
mSht.Cells(s1, 1).Value = mTmp
End If
s1 = s1 + 1
End If
If m1 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, m1 + 7, 8)
mTmp1 = Replace(mTmp, "/", "")
If IsNumeric(mTmp1) Then
mSht.Cells(s2, 2).Value = mTmp
End If
s2 = s2 + 1
End If
If n1 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, n1 + 6, 2)
If IsNumeric(mTmp) Then
mSht.Cells(s3, 3).Value = mTmp
End If
s3 = s3 + 1
End If
If n2 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, n2 + 6, 2)
If IsNumeric(mTmp) Then
mSht.Cells(s4, 4).Value = mTmp
End If
s4 = s4 + 1
End If
If n3 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, n3 + 6, 2)
If IsNumeric(mTmp) Then
mSht.Cells(s5, 5).Value = mTmp
End If
s5 = s5 + 1
End If
If n4 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, n4 + 6, 2)
If IsNumeric(mTmp) Then
mSht.Cells(s6, 6).Value = mTmp
End If
s6 = s6 + 1
End If
If n5 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, n5 + 6, 2)
If IsNumeric(mTmp) Then
mSht.Cells(s7, 7).Value = mTmp
End If
s7 = s7 + 1
End If
If n6 > 0 Then
mLen = Len(myStr)
mTmp = Mid(myStr, n6 + 6, 2)
If IsNumeric(mTmp) Then
mSht.Cells(s8, 8).Value = mTmp
End If
s8 = s8 + 1
End If
End If
Loop
.Close
End With
Set myTxt = Nothing '物件的釋放
Set myFso = Nothing
Next
End If
End With
End With
mSht.Range("a1:h1") = Array("期別", "日期", "一", "二", "三", "四", "五", "六")
mSht.Range("a1").Sort key1:=Range("a1"), order1:=xlAscending, header:=xlYes
For i = 2 To mSht.[a65536].End(xlUp).Row
mSht.Cells(i, 10) = mSht.Cells(i, 3) & mSht.Cells(i, 4) & mSht.Cells(i, 5) & mSht.Cells(i, 6) & mSht.Cells(i, 7) & mSht.Cells(i, 8) & mSht.Cells(i, 9)
Next
mSht.Range("j1") = "組合字串"
Set myFs = Nothing
Set mSht = Nothing
Set mRng = Nothing
End Sub
感謝各位大大。 |
發表於 2010-11-17 06:16
| 
