从字符串中提取数字 - VBA答案

【问题标题】：Number Extraction from String - VBA从字符串中提取数字 - VBA
【发布时间】：2017-06-30 13:00:25
【问题描述】：

我有一个包含大约 7000 条记录的列表，这些记录是带有数字的字符串。我需要提取所有数字，尤其是那些以“（”、“#”或“S”开头的数字。我们需要提取票号，以便分析每种类型存在多少问题票。下面是我写的代码。我认为一个数组可能会更好，但我无法弄清楚如何让它工作，所以现在，它循环遍历每一行中的每个字符，并且如果字符是数字，它开始复制并粘贴下一列中的数字，直到字符不再是数字。它将每组数字放在一个新列中，直到完成该行中的所有字符。

问题是它需要很长时间。上次我让它一路走下去，花了一个多小时。最近，我在进行更改时，我让它运行了大约 10 分钟然后停止它，它完成了大约 1200 条记录。每行最多可包含 100 个字符，但大多数接近 30 个。

有什么方法可以加快计算速度？

  Sub findNumbers1()

    Dim v As Integer, Length As Long, str As String, i As Long, r As Range, 
    lastRow As Long, nextCol, nextRow As Long, result, ArrayResult As String, ws 
    As Worksheet

nextRow = 0
nextCol = 0
Set ws = Worksheets("Sheet2")
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set r = ws.Range("A2:A6885")

 nextRow = 1
For Each cell In r

str = cell.Value
Length = Len(str)
i = 1
nextCol = 2
nextRow = nextRow + 1

    Do Until i > Length
         If Mid(cell.Value, i, 1) = "(" Then

                    If IsNumeric(Mid(cell.Value, i + 1, 1)) Then
                        Do While IsNumeric(Mid(cell.Value, i + 1, 1))
                            result = Mid(cell.Value, i + 1, 1)
                            ArrayResult = ArrayResult + result
                            ws.Cells(nextRow, nextCol).Value = ArrayResult
                            i = i + 1
                        Loop
                        ArrayResult = ""
                        nextCol = nextCol + 1
                     Else
                        nextCol = ws.Cells(nextRow, Columns.Count).End(xlToLeft).Column + 1
                    End If
        End If

        If Mid(cell.Value, i, 1) = "#" Then

                    If IsNumeric(Mid(cell.Value, i + 1, 1)) Then
                        Do While IsNumeric(Mid(cell.Value, i + 1, 1))
                            result = Mid(cell.Value, i + 1, 1)
                            ArrayResult = ArrayResult + result
                            ws.Cells(nextRow, nextCol).Value = ArrayResult
                            i = i + 1
                        Loop
                        ArrayResult = ""
                        nextCol = nextCol + 1
                    Else
                        nextCol = ws.Cells(nextRow, Columns.Count).End(xlToLeft).Column + 1
                    End If
        End If

        If Mid(cell.Value, i, 1) = "S " Then

                    If IsNumeric(Mid(cell.Value, i + 1, 1)) Then
                        Do While IsNumeric(Mid(cell.Value, i + 1, 1))
                            result = Mid(cell.Value, i + 1, 1)
                            ArrayResult = ArrayResult + result
                            ws.Cells(nextRow, nextCol).Value = ArrayResult
                            i = i + 1
                        Loop
                        ArrayResult = ""
                        nextCol = nextCol + 1
                     Else
                        nextCol = ws.Cells(nextRow, Columns.Count).End(xlToLeft).Column + 1
                    End If
        End If
    i = i + 1
    Loop
    ArrayResult = ""
    nextCol = nextCol + 1
Next cell

result = ""
ArrayResult = ""

Call pasteNoITMS

ws.ShowAllData

End Sub


Sub findNumbers2()
'pull all numbers from remaining applications after findnumbers1 runs.

Dim v As Integer, Length As Long, str As String, i As Long, r As Range, lastRow As Long, nextCol, nextRow As Long, result, ArrayResult As String, ws As Worksheet
result = ""
ArrayResult = ""
nextRow = 0
nextCol = 0
Set ws = Worksheets("2ndPull")
lastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
Set r = ws.Range("A2:A2000")




 nextRow = 1
For Each cell In r

str = cell.Value
Length = Len(str)
i = 1
nextCol = 2
nextRow = nextRow + 1
ArrayResult = ""

    Do Until i > Length

                    If IsNumeric(Mid(cell.Value, i + 1, 1)) Then
                        Do While IsNumeric(Mid(cell.Value, i + 1, 1))
                            result = Mid(cell.Value, i + 1, 1)
                            ArrayResult = ArrayResult + result
                            ws.Cells(nextRow, nextCol).Value = ArrayResult
                            i = i + 1
                        Loop
                        ArrayResult = ""
                        nextCol = nextCol + 1
                     Else
                        nextCol = ws.Cells(nextRow, Columns.Count).End(xlToLeft).Column + 1
                    End If

    i = i + 1
    Loop
    ArrayResult = ""
    nextCol = nextCol + 1
Next cell

result = ""
ArrayResult = ""

Call sortPulled

End Sub

【问题讨论】：

位数是否一致（即始终为 7 位）？如果是这样，正则表达式将为您完成这项任务。如果不是，请提供有关数据外观的更多详细信息。
如果您的代码已经正常运行，最好将这个问题发布到代码审查社区。有关一般提示，请查看this link。
尝试切换screen updating
谢谢大家。 @BerticusMaximus，我很欣赏评论社区的提示。我不经常使用 SO，但我下次会这样做。
请参阅下面的一些示例数据：VSDN (22542) - NA 和移动 (23468) SMART - Material Trigger (SMART) (11417) Smart (19221), vid(20703), (12569) , 驱动器 (20184), 数据 (13742)

标签： string vba excel numbers information-extraction

【解决方案1】：

您可以做出的最重要的改进是尽量减少与范围的交互

您还可以将搜索范围缩小到您需要的情况：(、#、S

类似这样的：

Option Explicit

Public Sub findNumbers2()
    Const DELIMS = "(, #, S, , Test"
    Dim ws As Worksheet, lc As Long, lr As Long, allFound As Long, nxt As Long
    Dim ur As Variant, ubR As Long, ubC As Long, r As Long, c As Long, i As Long
    Dim delim As Variant, dMax As Long, found As Long, result As Variant, t As Double

    t = Timer '------------------------------------------------------------------------
    delim = Split(DELIMS, ","): dMax = UBound(delim)
    For i = 0 To dMax
        If Len(delim(i)) > 0 Then
            If Len(delim(i)) > 1 Then delim(i) = Trim(delim(i))
        End If
    Next
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With ws.UsedRange
        ur = .Value2
        lc = .Columns.Count
        lr = .Rows.Count
    End With
    ubR = UBound(ur, 1): ubC = UBound(ur, 2)

    result = ws.UsedRange.Offset(0, lc + 1)
    For r = 1 To ubR
        For c = 1 To ubC
            For i = 0 To dMax
                found = InStr(ur(r, c), delim(i))
                If found > 0 Then
                    nxt = found
                    Do
                        found = Val(Mid(ur(r, c), nxt + 1))
                        If found > 0 Then
                            allFound = allFound + 1
                            result(r, c) = result(r, c) & found & ", "
                        End If
                        nxt = InStr(nxt + 1, ur(r, c), delim(i))
                    Loop While nxt > 0
                End If
            Next
        Next
    Next
    ws.UsedRange.Offset(0, lc + 1).Value2 = result: 'ws.UsedRange.EntireColumn.AutoFit
    Debug.Print "Rows: " & lr & "; duration: " & Format(Timer - t, "#,###.00") & " secs"
End Sub

7 列数据的测试结果，每个单元格包含一个或多个数字：

Rows: 100,001; duration:  5.77 secs
Rows: 500,005; duration: 28.25 secs

【讨论】：

这当然很有帮助！它有效，但是，我的某些数据行有多组数字，用字母分隔。像这样：“EDPS - (18728);EPDF - Enterprise PDF (19636) - 信息”。所以我需要弄清楚如何在行内多次运行循环。
哦！我可以把每一个字符串放在自己的单元格中运行它……仍然需要大约 15 秒，但比以前好多了！
啊，但没有找到任何只是数字的东西......例如“Marketing & Pricing 22749”。
我更新了它，因此您也可以使用空格作为分隔符，如果任何单元格包含多个分隔符它将提取所有分隔符之后的所有数字，但如果有多个数字由空格分隔，它将连接数字，因此在此文本中：““Marketing & Pricing 111 222 333”您将获得 111222333
效果很好！谢谢保罗。一个问题;数组...它将每个值保存到新行上。我可以在底部看到这一点，这是有道理的。有没有办法将每一行的值保存在同一行但不同的列中？例如，如果算法有 3 个值，请将其放在第 2、3、4 列？我假设数组有一些限制......我问的原因是一些字符串具有我们不想要的随机值，如日期、服务器名称等。我们的想法是，我们可以查看结果并进行快速的视觉比较，以确保显示的值准确。

【解决方案2】：

在代码的开头：

Application.ScreenUpdating = False

然后在最后（在任何关闭之前）放置：

Application.ScreenUpdating = True

这肯定会加快流程，因为它无需向您展示它在做什么。以更有效的方式重写它是理想的，但这可能有助于加快它的速度。

【讨论】：

【解决方案3】：

您应该避免为每个字符访问cell.Value。只需读取每个单元格值一次 - 您已经将其分配给变量 str。用mid(str, i, 1)（和类似的）替换mid(cell.value, i, 1)-statements 应该会显着加快例程。

【讨论】：