excel - Runtime error 5020: Replace content in cells based on contents of a different cell (using regex patterns) - Stack Overfl

admin管理员组

文章数量:1406052

At work we use a tool called FNT command for planning and documentation of cabling, server racks, network infrastructure and so on. It can export planned connections to an excel file but its filled with so much junk that its about 90% junk text that doesn't matter to the engineer executing the task.

I'm not a software engineer but i was able to get something together to address this using copilot and basic regex knowledge. The script replaces junk text with nothing or a semicolon (used as a delimiter for "text to columns" in another script).

I keep getting the runtime error 5020 at one of my loops so im hoping someone can have a look. Additionally, chances are good that my script is bloated or in other ways improvable, even if i get it to work. If there are better methods to do the task please do share your ideas.

Set matches = regexUmpatchen.Execute(cell.Value) is the line that gets tagged when I click "debugging" after trying to run the script. I removed the last ElseIf loop with comments, which causes the script to run fine. Online research idicates the issue is about the regex pattern but ive tested it in regex101 and found no issues.

Here is an example of 2 cells on which that part of the script should work:

And this is my script:

Sub CleanupAndInsertSemicolon2()
    Dim ws As Worksheet
    Dim cell As Range
    Dim regexVerbindung1 As Object
    Dim regexVerbindung2 As Object
    Dim regexKarte1 As Object
    Dim regexKarte2 As Object
    Dim regexUmpatchen As Object
    Dim regexUmpatchen2 As Object
    Dim regexNach As Object
    Dim regexCleanup As Object
    Dim regexLineBreaks As Object
    Dim regexCondition As Object
    Dim matches As Object
    Dim match As Object
    Dim beschreibungColumn As Range
    
    
    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet
    
    ' Create regex objects for pattern matching later in the script.
    Set regexVerbindung1 = CreateObject("VBScript.RegExp")
    regexVerbindung1.pattern = "^.+?(und|nach)"
    
    Set regexVerbindung2 = CreateObject("VBScript.RegExp")
    regexVerbindung2.pattern = "Kabel.+\nVon: "
    
    Set regexKarte1 = CreateObject("VBScript.RegExp")
    regexKarte1.pattern = "Objekttyp.+"
    
    Set regexKarte2 = CreateObject("VBScript.RegExp")
    regexKarte2.pattern = "Standort: "
    
    Set regexUmpatchen = CreateObject("VBScript.RegExp")
    regexUmpatchen.pattern = "mit.+\nVon: "
    
    Set regexUmpatchen2 = CreateObject("VBScript.RegExp")
    regexUmpatchen.pattern = "(Umpatchen.\(Datenkabel\).in"
    
    Set regexCondition = CreateObject("VBScript.RegExp")
    regexCondition.pattern = "(Verbindung|Patchen).\(Datenkabel\)"
    
    Set regexNach = CreateObject("VBScript.RegExp")
    regexCondition.pattern = "Nach: "
    
    Set regexPlatzieren = CreateObject("VBScript.RegExp")
    regexCondition.pattern = "platzieren."
    
    ' Find the "Beschreibung" column and save it as 'beschreibungColumn' so that we can quickly reference this column.
    Set beschreibungColumn = ws.Rows(1).Find("Beschreibung", LookIn:=xlValues, LookAt:=xlWhole).EntireColumn
    
    ' We now loop through each cell in the "Beschreibung" column, looking for regex patterns and replacing matches with the things I want. A cell is ignored if the previous column does not have a specified string that describes the action that the engineer has to do with the cable or optic module. (Umpatchen - connect elsewhere, Verbinden - Connect, lösen - remove connection and so on)
    
    For Each cell In beschreibungColumn.Cells
        If Not IsEmpty(cell.Value) Then
           If InStr(1, cell.Value, "Neuer Patch", vbTextCompare) > 0 Or InStr(1, cell.Value, "Neues Bündelkabel", vbTextCompare) > 0 Or InStr(1, cell.Value, "lösen", vbTextCompare) > 0 Then
                Set matches = regexVerbindung1.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
                
                Set matches = regexVerbindung2.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match

              ElseIf InStr(1, cell.Value, "platzieren", vbTextCompare) > 0 Then
                Set matches = regexKarte1.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
                
                Set matches = regexKarte2.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
                
                Set matches = regexPlatzieren.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match

              ElseIf InStr(1, cell.Value, "Umpatchen", vbTextCompare) > 0 Then
                Set matches = regexUmpatchen.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match
           
                Set matches = regexUmpatchen2.Execute(cell.Value)
               For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
           
                Set matches = regexNach.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match
                
           
            End If
        End If
    Next cell
End Sub

Update: Example of "Aktion/Beschreibung" content where the script is working (New script by @taller is being used/discussed about from here on)

About the tables: (\n) → newline should be there but was replaced due to limitations of the markdown format regarding text that exceeds one line

Umlaut characters have been replaced with their base letter (Ü-U Ö-O Ä-A)

Bold text indicates that the word is intended to be found by the script, causing it to perform the regex-replace operations for the corresponding cell in the Beschreibung column.

Aktion	Beschreibung
Einfache Verbindung losen	Junktext und ValidInfo1(\n)Junktext(\n)Von: ValidInfo2 Nach: ValidInfo3
Umpatchen (einfach)	Junktext in ValidInfo1 mit Junktext(\n)Von: ValidInfo2 Nach: ValidInfo3

At work we use a tool called FNT command for planning and documentation of cabling, server racks, network infrastructure and so on. It can export planned connections to an excel file but its filled with so much junk that its about 90% junk text that doesn't matter to the engineer executing the task.

I'm not a software engineer but i was able to get something together to address this using copilot and basic regex knowledge. The script replaces junk text with nothing or a semicolon (used as a delimiter for "text to columns" in another script).

I keep getting the runtime error 5020 at one of my loops so im hoping someone can have a look. Additionally, chances are good that my script is bloated or in other ways improvable, even if i get it to work. If there are better methods to do the task please do share your ideas.

Set matches = regexUmpatchen.Execute(cell.Value) is the line that gets tagged when I click "debugging" after trying to run the script. I removed the last ElseIf loop with comments, which causes the script to run fine. Online research idicates the issue is about the regex pattern but ive tested it in regex101 and found no issues.

Here is an example of 2 cells on which that part of the script should work:

And this is my script:

Sub CleanupAndInsertSemicolon2()
    Dim ws As Worksheet
    Dim cell As Range
    Dim regexVerbindung1 As Object
    Dim regexVerbindung2 As Object
    Dim regexKarte1 As Object
    Dim regexKarte2 As Object
    Dim regexUmpatchen As Object
    Dim regexUmpatchen2 As Object
    Dim regexNach As Object
    Dim regexCleanup As Object
    Dim regexLineBreaks As Object
    Dim regexCondition As Object
    Dim matches As Object
    Dim match As Object
    Dim beschreibungColumn As Range
    
    
    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet
    
    ' Create regex objects for pattern matching later in the script.
    Set regexVerbindung1 = CreateObject("VBScript.RegExp")
    regexVerbindung1.pattern = "^.+?(und|nach)"
    
    Set regexVerbindung2 = CreateObject("VBScript.RegExp")
    regexVerbindung2.pattern = "Kabel.+\nVon: "
    
    Set regexKarte1 = CreateObject("VBScript.RegExp")
    regexKarte1.pattern = "Objekttyp.+"
    
    Set regexKarte2 = CreateObject("VBScript.RegExp")
    regexKarte2.pattern = "Standort: "
    
    Set regexUmpatchen = CreateObject("VBScript.RegExp")
    regexUmpatchen.pattern = "mit.+\nVon: "
    
    Set regexUmpatchen2 = CreateObject("VBScript.RegExp")
    regexUmpatchen.pattern = "(Umpatchen.\(Datenkabel\).in"
    
    Set regexCondition = CreateObject("VBScript.RegExp")
    regexCondition.pattern = "(Verbindung|Patchen).\(Datenkabel\)"
    
    Set regexNach = CreateObject("VBScript.RegExp")
    regexCondition.pattern = "Nach: "
    
    Set regexPlatzieren = CreateObject("VBScript.RegExp")
    regexCondition.pattern = "platzieren."
    
    ' Find the "Beschreibung" column and save it as 'beschreibungColumn' so that we can quickly reference this column.
    Set beschreibungColumn = ws.Rows(1).Find("Beschreibung", LookIn:=xlValues, LookAt:=xlWhole).EntireColumn
    
    ' We now loop through each cell in the "Beschreibung" column, looking for regex patterns and replacing matches with the things I want. A cell is ignored if the previous column does not have a specified string that describes the action that the engineer has to do with the cable or optic module. (Umpatchen - connect elsewhere, Verbinden - Connect, lösen - remove connection and so on)
    
    For Each cell In beschreibungColumn.Cells
        If Not IsEmpty(cell.Value) Then
           If InStr(1, cell.Value, "Neuer Patch", vbTextCompare) > 0 Or InStr(1, cell.Value, "Neues Bündelkabel", vbTextCompare) > 0 Or InStr(1, cell.Value, "lösen", vbTextCompare) > 0 Then
                Set matches = regexVerbindung1.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
                
                Set matches = regexVerbindung2.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match

              ElseIf InStr(1, cell.Value, "platzieren", vbTextCompare) > 0 Then
                Set matches = regexKarte1.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
                
                Set matches = regexKarte2.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
                
                Set matches = regexPlatzieren.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match

              ElseIf InStr(1, cell.Value, "Umpatchen", vbTextCompare) > 0 Then
                Set matches = regexUmpatchen.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match
           
                Set matches = regexUmpatchen2.Execute(cell.Value)
               For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, "")
                Next match
           
                Set matches = regexNach.Execute(cell.Value)
                For Each match In matches
                    cell.Value = Replace(cell.Value, match.Value, ";")
                Next match
                
           
            End If
        End If
    Next cell
End Sub

Update: Example of "Aktion/Beschreibung" content where the script is working (New script by @taller is being used/discussed about from here on)

About the tables: (\n) → newline should be there but was replaced due to limitations of the markdown format regarding text that exceeds one line

Umlaut characters have been replaced with their base letter (Ü-U Ö-O Ä-A)

Bold text indicates that the word is intended to be found by the script, causing it to perform the regex-replace operations for the corresponding cell in the Beschreibung column.

Aktion	Beschreibung
Einfache Verbindung losen	Junktext und ValidInfo1(\n)Junktext(\n)Von: ValidInfo2 Nach: ValidInfo3
Umpatchen (einfach)	Junktext in ValidInfo1 mit Junktext(\n)Von: ValidInfo2 Nach: ValidInfo3

Non-functional cell content

Aktion	Beschreibung
Neuer Patch (einfach)	Junktext und ValidInfo1(\n)Junktext(\n)Von: ValidInfo2 Nach: ValidInfo3
Neues Bundelkabel	Junktext und ValidInfo1(\n)Junktext(\n)Von: ValidInfo2 Nach: ValidInfo3

Where the Aktion column has either Neuer Patch or Neues Bundelkabel it seems like the script doesn't find a match and skips them. Since neither the term Neues nor Neuer appears in any other type of Aktion cell, we can even shorten the text that has to be present in Aktion to only those terms but the regex-replacement still does not happen upon executing the script.

• excel
• regex
• vba
• regexp-replace

Share Improve this question Follow edited Mar 12 at 8:35 TheNewGuy asked Mar 6 at 15:49 TheNewGuyTheNewGuy 2511 silver badge44 bronze badges 6

• 1 After Set regexUmpatchen2 = you have regexUmpatchen.pattern = so regexUmpatchen2 has no pattern. Same for regexNach and regexPlatzieren – CDP1802 Commented Mar 6 at 16:53
• 1 5020 error - "(Umpatchen.\(Datenkabel\).in" is not a valid pattern because of unmatched (. – CDP1802 Commented Mar 6 at 17:41
• Maybe this is more suitable for CodeReview? – DuesserBaest Commented Mar 7 at 10:17
• 2 @DuesserBaest No. The code doesn't work as intended, "I keep getting the runtime error 5020", and so is off-topic on Code Review. – Peilonrayz Commented Mar 7 at 10:47
• 2 @DuesserBaest You clearly do not know Code Review's rules. – Peilonrayz Commented Mar 7 at 11:32

 |  Show 1 more comment

1 Answer 1

Sorted by: Reset to default 3

Here are some updates to the script:

1. Reuse the RegExp object instead of creating multiple instances.
2. Loop only through the used cells in the target column.
3. Use RegExp for replacements.
4. Load cell values into an array to improve processing efficiency.

Note: it's untesed script

Sub CleanupAndInsertSemicolon2()
    Dim ws As Worksheet
    Dim cell As Range
    Dim regexObj As Object
    Dim matches As Object
    Dim beschreibungColumn As Range
    Dim dataArray As Variant
    Dim i As Long
    Dim lastRow As Long

    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet

    ' Create a single RegExp object
    Set regexObj = CreateObject("VBScript.RegExp")
    regexObj.Global = True ' Important for Replace method

    ' Find the "Beschreibung" column
    Set beschreibungColumn = ws.Rows(1).Find("Beschreibung", LookIn:=xlValues, LookAt:=xlWhole)

    ' Find the last used row in the "Beschreibung" column
    lastRow = ws.Cells(ws.Rows.Count, beschreibungColumn.Column).End(xlUp).Row

    ' Load cell values into an array, using only the used range
    Dim dataRng As Range: Set dataRng = beschreibungColumn.Offset(1).Resize(lastRow - 1)
    dataArray = dataRng.Value

    ' Loop through the array and perform replacements
    For i = 1 To UBound(dataArray, 1)
        If Not IsEmpty(dataArray(i, 1)) Then
            If InStr(1, dataArray(i, 1), "Neuer", vbTextCompare) > 0 Or _
                InStr(1, dataArray(i, 1), "Neues", vbTextCompare) > 0 Or _
                InStr(1, dataArray(i, 1), "lösen", vbTextCompare) > 0 Then
                ' Pattern 1
                regexObj.Pattern = "^.+?(und|nach)"
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), "")

                ' Pattern 2
                regexObj.Pattern = "Kabel.+\nVon: "
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), ";")

            ElseIf InStr(1, dataArray(i, 1), "platzieren", vbTextCompare) > 0 Then
                ' Pattern 3
                regexObj.Pattern = "Objekttyp.+"
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), "")

                ' Pattern 4
                regexObj.Pattern = "Standort: "
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), "")

                ' Pattern 5
                regexObj.Pattern = "platzieren."
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), ";")

            ElseIf InStr(1, dataArray(i, 1), "Umpatchen", vbTextCompare) > 0 Then
                ' Pattern 6
                regexObj.Pattern = "mit.+\nVon: "
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), ";")

                ' Pattern 7
                regexObj.Pattern = "(Umpatchen.\(Datenkabel\).in)"
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), "")

                ' Pattern 8
                regexObj.Pattern = "Nach: "
                dataArray(i, 1) = regexObj.Replace(dataArray(i, 1), ";")

            End If
        End If
    Next i

    ' Write array back to the worksheet
    dataRng.Value = dataArray ' Ensure write back to the same used range

    Set regexObj = Nothing
End Sub

---

Update: Modify the script based on the sample data in the original post. Changes in the script are marked with *Change.

Option Explicit
Sub CleanupAndInsertSemicolon2()
    Dim ws As Worksheet
    Dim cell As Range
    Dim regexObj As Object
    Dim matches As Object
    Dim beschreibungColumn As Range
    Dim dataArray As Variant
    Dim i As Long
    Dim lastRow As Long

    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet

    ' Create a single RegExp object
    Set regexObj = CreateObject("VBScript.RegExp")
    regexObj.Global = True ' Important for Replace method

    ' Find the "Beschreibung" column
    Set beschreibungColumn = ws.Rows(1).Find("Beschreibung", LookIn:=xlValues, LookAt:=xlWhole)

    ' Find the last used row in the "Beschreibung" column
    lastRow = ws.Cells(ws.Rows.Count, beschreibungColumn.Column).End(xlUp).Row

    ' Load cell values into an array, using only the used range
    ' *Change: Aktion column is used in the If clause, dataRng should include TWO columns
    Dim dataRng As Range: Set dataRng = beschreibungColumn.Offset(1, -1).Resize(lastRow - 1, 2)
    dataArray = dataRng.Value

    ' Loop through the array and perform replacements
    ' *Change: all replacement should be applied on the 2nd column (Beschreibung)
    For i = 1 To UBound(dataArray, 1)
        If Not IsEmpty(dataArray(i, 1)) Then
            ' *Change: InStr doesn't support wildcard, change to Like operator
            If InStr(1, dataArray(i, 1), "Neuer", vbTextCompare) > 0 Or _
                InStr(1, dataArray(i, 1), "Neues", vbTextCompare) > 0 Or _
                dataArray(i, 1) Like "*l?sen*" Then
                ' Pattern 1
                regexObj.Pattern = "^.+?(und|nach)"
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), "")
                ' Pattern 2
                ' *Change: line break in a cell is Chr(10) instead of \n (ASCII is 13)
                regexObj.Pattern = "Kabel.+" & Chr(10) & "Von: "
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), ";")

            ElseIf InStr(1, dataArray(i, 1), "platzieren", vbTextCompare) > 0 Then
                ' Pattern 3
                regexObj.Pattern = "Objekttyp.+"
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), "")

                ' Pattern 4
                regexObj.Pattern = "Standort: "
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), "")

                ' Pattern 5
                regexObj.Pattern = "platzieren."
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), ";")

            ElseIf InStr(1, dataArray(i, 1), "Umpatchen", vbTextCompare) > 0 Then
                ' Pattern 6
                regexObj.Pattern = "mit.+" & Chr(10) & "Von: "
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), ";")

                ' Pattern 7
                regexObj.Pattern = "(Umpatchen.\(Datenkabel\).in)"
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), "")

                ' Pattern 8
                regexObj.Pattern = "Nach: "
                dataArray(i, 2) = regexObj.Replace(dataArray(i, 2), ";")

            End If
        End If
    Next i

    ' Write array back to the worksheet
    dataRng.Value = dataArray ' Ensure write back to the same used range

    Set regexObj = Nothing
End Sub

本文标签：