我一直在崩溃,试图创建一个例程来识别TXT中的字符串并将该信息复制到Excel工作表。 这是我的测试TXT文件中的内容:
LIN+1++7501005111133:EN'
PIA+1+008112338:IN+.:VN'
PRI+AAB:760.73::EUP::EA'
PAC+1+3'
LIN+2++7501024201969:EN'
PIA+1+008126016:IN+.:VN'
PRI+AAB:732.07::EUP::EA'
PAC+1+3'
LIN+3++7501024201976:EN'
PIA+1+008126023:IN+.:VN'
PRI+AAB:710.86::EUP::EA'
PAC+1+3'
LIN+4++7501005114103:EN'
PIA+1+008126289:IN+.:VN'
PRI+AAB:737.91::EUP::EA'
PAC+1+3'
LIN+5++7501005113960:EN'
PIA+1+008126310:IN+.:VN'
PRI+AAB:737.91::EUP::EA'
PAC+1+3'
例如,我需要提取的所有以“ PIA + 1”开头的行。在这种情况下,我应该在excel中添加以下结果:
PIA+1+008112338:IN+.:VN'
PIA+1+008126016:IN+.:VN'
PIA+1+008126023:IN+.:VN'
PIA+1+008126289:IN+.:VN'
PIA+1+008126310:IN+.:VN'
问题是我希望有一个过程可以重用于文件中的其他段,例如“ LIN +”或其他。我已经创建了这段代码,但这只是检索我的第一个匹配项:
Sub Extract_EDI_Data_2()
Dim wrk As Workbook
Dim shtSource As Worksheet
Dim shtResult As Worksheet
Dim rng As Range
Dim fndSection As Range
Dim fndValue As Range
Dim data As QueryTable
Dim strFile
Dim strPath As String
Dim strExt As String
Dim strSection As String
Dim strValue As String
ThisWorkbook.Sheets("EDI_Data").Range("A2:AI100000").ClearContents
' ======== BEGIN SETTINGS ========
strPath = "C:\Edicom\Input\"
strExt = "*.EDI"
strSection = "LIN+1++"
strValue = "LIN+1++"
' ======== END SETTINGS ========
Set wrk = Application.ThisWorkbook
With wrk
Set shtResult = ThisWorkbook.Worksheets("EDI_Data_Item")
Set shtSource = .Worksheets.Add
End With
With shtResult
.Cells(1, 2).Value = strValue
.Name = "EDI_Data_Item"
End With
strFile = Dir(strPath & strExt, vbNormal)
Do Until strFile = ""
Set data = shtSource.QueryTables.Add(Connection:="TEXT;" & strPath & strFile, Destination:=shtSource.Cells(1, 2))
With data
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = True
.TextFileOtherDelimiter = True
.TextFileOtherDelimiter = "'"
.Refresh BackgroundQuery:=True
End With
Set fndSection = data.ResultRange.Find(strSection)
If Not fndSection Is Nothing Then
Set fndValue = data.ResultRange.Find(strValue, fndSection)
If Not fndValue Is Nothing Then
shtResult.Cells(shtResult.Rows.Count, 2).End(xlUp).Offset(1).Value = Replace(fndValue, strValue, "")
End If
End If
With data
.ResultRange.Delete
.Delete
End With
strFile = Dir
Loop
Application.DisplayAlerts = False
shtSource.Delete
Application.DisplayAlerts = True
End Sub
有什么办法解决这个难题吗?
感谢支持。
致谢
答案 0 :(得分:1)
尝试更换...
Set fndSection = data.ResultRange.Find(strSection)
If Not fndSection Is Nothing Then
Set fndValue = data.ResultRange.Find(strValue, fndSection)
If Not fndValue Is Nothing Then
shtResult.Cells(shtResult.Rows.Count, 2).End(xlUp).Offset(1).Value = Replace(fndValue, strValue, "")
End If
End If
使用
Set fndValue = data.ResultRange.Find(strValue)
If Not fndValue Is Nothing Then
strFirstAddress = fndValue.Address
Do
shtResult.Cells(shtResult.Rows.Count, 2).End(xlUp).Offset(1).Value = Replace(fndValue, strValue, "")
Set fndValue = data.ResultRange.FindNext(fndValue)
Loop While fndValue.Address <> strFirstAddress
End If
实际上,您的代码可以按如下方式重写...
Option Explicit
Sub Extract_EDI_Data_2()
Dim shtSource As Worksheet
Dim shtResult As Worksheet
Dim fndValue As Range
Dim data As QueryTable
Dim strFile
Dim strPath As String
Dim strExt As String
Dim strValue As String
Dim strFirstAddress As String
Application.ScreenUpdating = False
ThisWorkbook.Sheets("EDI_Data_Item").Range("A2:AI100000").ClearContents
' ======== BEGIN SETTINGS ========
strPath = "C:\Edicom\Input\"
strExt = "*.EDI"
strValue = "PIA+1"
' ======== END SETTINGS ========
With ThisWorkbook
Set shtResult = .Worksheets("EDI_Data_Item")
Set shtSource = .Worksheets.Add
End With
With shtResult
.Cells(1, 2).Value = strValue
.Name = "EDI_Data_Item"
End With
strFile = Dir(strPath & strExt, vbNormal)
Do Until strFile = ""
Set data = shtSource.QueryTables.Add(Connection:="TEXT;" & strPath & strFile, Destination:=shtSource.Cells(1, 2))
With data
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileConsecutiveDelimiter = True
.TextFileOtherDelimiter = True
.TextFileOtherDelimiter = "'"
.Refresh BackgroundQuery:=True
End With
Set fndValue = data.ResultRange.Find(strValue)
If Not fndValue Is Nothing Then
strFirstAddress = fndValue.Address
Do
shtResult.Cells(shtResult.Rows.Count, 2).End(xlUp).Offset(1).Value = Replace(fndValue, strValue, "")
Set fndValue = data.ResultRange.FindNext(fndValue)
Loop While fndValue.Address <> strFirstAddress
End If
With data
.ResultRange.Delete
.Delete
End With
strFile = Dir
Loop
Application.DisplayAlerts = False
shtSource.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
您会注意到Option Explicit
语句包含在模块顶部。这将强制显式声明变量,并且可以帮助捕获潜在的错误。另外,ScreenUpdating在代码的开头关闭,然后在代码结尾重新打开。这应该使代码更有效率。另外,我假设您是要清除名为EDI_Data_Item
而不是EDI_Data
的工作表的内容。