那位大神帮我看一下这个代码为什么二次运行无法提取数据

hjq018 · 发表于 2018-9-13 19:50

点击无法提取到数据，那位大神给完善一下，主要是二大块，表1是提取开始新的交易与交易保存成功之前的销售数据，表2是提取以付款方式为“付款方式储值卡：”会员卡消费数据，已可以提取一次，可是二次点击无法取数据。

chxw68 · 发表于 2018-9-13 20:34

Sub test()
Dim r%, i%
Dim arr, brr
Dim reg1 As New RegExp
Dim reg2 As New RegExp
Dim reg3 As New RegExp
Dim flg1 As Boolean
Dim flg2 As Boolean
Dim mypath$, myname$
With reg1
.Global = False
.Pattern = "交易数量为([\d\.]+)的商品：(\d+)价格为：([\d\.]+)"
End With
With reg2
.Global = False
.Pattern = "零售手输会员卡卡号：([\d]+)"
End With
With reg3
.Global = False
.Pattern = "(\d{4}-\d{2}-\d{2})\s+\d{2}:\d{2}:\d{2}\s+\d{3}\s+付款方式\s+储值卡：([\d\.]+)"
End With
mypath = ThisWorkbook.Path & ""
myname = "log20180902.txt"
If Dir(mypath & myname) = "" Then
MsgBox mypath & myname & "不存在！"
Exit Sub
End If
ss = ReadUTF(mypath & myname)
arr = Split(ss, vbCrLf)
ReDim brr(1 To UBound(arr), 1 To 3)
ReDim crr(1 To UBound(arr), 1 To 3)
m = 0
n = 0
flg1 = False
For i = 0 To UBound(arr)
ss = Trim(arr(i))
If InStr(ss, "开始新的交易") <> 0 Then
flg1 = True
ElseIf InStr(ss, "交易保存成功") <> 0 Then
flg1 = False
End If
If flg1 Then
Set mh = reg1.Execute(ss)
If mh.Count > 0 Then
m = m + 1
brr(m, 1) = mh(0).SubMatches(1)
brr(m, 2) = mh(0).SubMatches(0)
brr(m, 3) = mh(0).SubMatches(2)
End If
End If
Next
For i = UBound(arr) To 0 Step -1
ss = Trim(arr(i))
If InStr(ss, "交易保存成功") <> 0 Then
flg1 = True
ElseIf InStr(ss, "开始新的交易") <> 0 Then
flg1 = False
End If
If flg1 Then
Set mh = reg3.Execute(ss)
If mh.Count > 0 Then
n = n + 1
crr(n, 1) = mh(0).SubMatches(0)
crr(n, 3) = mh(0).SubMatches(1)
flg2 = True
End If
If flg2 Then
Set mh = reg2.Execute(ss)
If mh.Count > 0 Then
crr(n, 2) = mh(0).SubMatches(0)
flg2 = False
End If
End If
End If
Next
With Worksheets("sheet1")
.UsedRange.Offset(1, 0).ClearContents
.Columns(1).NumberFormatLocal = "@"
If m > 0 Then
.Range("a2").Resize(m, UBound(brr, 2)) = brr
End If
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("a1:c" & r).Borders.LineStyle = xlContinuous
End With
With Worksheets("sheet2")
.UsedRange.Offset(1, 0).ClearContents
.Columns(2).NumberFormatLocal = "@"
If n > 0 Then
.Range("a2").Resize(n, UBound(crr, 2)) = crr
End If
r = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("a1:c" & r).Borders.LineStyle = xlContinuous
End With
End Sub
Function ReadUTF(ByVal FileName As String) As String
With CreateObject("ADODB.Stream")
.Type = 2 '读取文本文件
.Mode = 3 '读写
.Open
.LoadFromFile FileName
.Charset = "UTF-8" '设定编码
.Position = 2
ReadUTF = .ReadText
.Close
End With
End Function

复制代码

chxw68 · 发表于 2018-9-13 20:35

详见附件。

Yalishanda30 · 发表于 2018-9-14 08:06

中文貌似乱码了，为什么

chxw68 · 发表于 2018-9-14 08:25

Yalishanda30 发表于 2018-9-14 08:06
中文貌似乱码了，为什么

这个文本文件是UTF-8编码。

lsdongjh · 发表于 2018-9-14 14:45

Option Explicit
Sub Main()
Dim strPath As String, strTxt As String, strTemp As String
Dim objReg As Object, strPat As String
Dim objMatchs As Object, objMatch As Object, lngCount As Long, lngRow As Long
Dim arrResult_A As Variant, arrResult_B As Variant
strPath = ThisWorkbook.Path & "\log20180902.txt"
If Dir(strPath) = "" Then Exit Sub
strTxt = LoadFile(strPath)
Set objReg = CreateObject("VBScript.RegExp")
strPat = "开始新的交易([\s\S]*?)(交易保存成功)"
With objReg
.Global = True
.Pattern = strPat
End With
If objReg.test(strTxt) = False Then Exit Sub
Set objMatchs = objReg.Execute(strTxt)
For Each objMatch In objMatchs
strTemp = strTemp & objMatch
Next
strPat = "交易数量为([\d\.]+)的商品：(\d+)价格为：([\d\.]+)"
With objReg
.Global = True
.Pattern = strPat
End With
Set objMatchs = objReg.Execute(strTemp)
lngCount = objMatchs.Count
ReDim arrResult_A(1 To lngCount, 1 To 3)
For lngRow = 0 To lngCount - 1
arrResult_A(lngRow + 1, 1) = objMatchs(lngRow).SubMatches(1)
arrResult_A(lngRow + 1, 2) = objMatchs(lngRow).SubMatches(0)
arrResult_A(lngRow + 1, 3) = objMatchs(lngRow).SubMatches(2)
Next
strPat = "零售手输会员卡卡号：([\d]+)[\s\S]*?(\d{4}-\d{2}-\d{2})\s+\d{2}:\d{2}:\d{2}\s+\d{3}\s+付款方式\s+储值卡：([\d\.]+)"
With objReg
.Global = True
.Pattern = strPat
End With
Set objMatchs = objReg.Execute(strTemp)
lngCount = objMatchs.Count
ReDim arrResult_B(1 To lngCount, 1 To 3)
For lngRow = 0 To lngCount - 1
arrResult_B(lngRow + 1, 1) = objMatchs(lngRow).SubMatches(1)
arrResult_B(lngRow + 1, 2) = objMatchs(lngRow).SubMatches(0)
arrResult_B(lngRow + 1, 3) = objMatchs(lngRow).SubMatches(2)
Next
Sheet1.Range("A2:C" & Rows.Count).ClearContents
Sheet1.Range("A2").Resize(UBound(arrResult_A), 3) = arrResult_A
Sheet2.Range("A2:C" & Rows.Count).ClearContents
Sheet2.Range("A2").Resize(UBound(arrResult_B), 3) = arrResult_B
End Sub
'读取UTF8文件
Function LoadFile(ByVal strFileName) As String
Dim objStream As Object
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2
.Mode = 3
.Open
.LoadFromFile strFileName
.Charset = "utf-8"
.Position = 2
LoadFile = .ReadText
.Close
End With
Set objStream = Nothing
End Function

复制代码

hjq018 · 发表于 2018-9-15 10:47

chxw68 发表于 2018-9-13 20:35
详见附件。

55555555555555。。为什么在我这就是不可以

		自动登录	找回密码
密码			免费注册

[求助] 那位大神帮我看一下这个代码为什么二次运行无法提取数据