Question

我一直在崩溃，试图创建一个例程来识别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

有什么办法解决这个难题吗？

感谢支持。

致谢

Answer 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的工作表的内容。

如何从TXT（VBA）提取行

1 个答案: