Question

Excel电子表格

我在A列（输入）中有一组10,000行以上的文本字符串，我需要获取数字（如果只有一个）或两者之和（如果有两个）。 / p>

代码

这是我拥有的VBA代码：

Sub ExtractNumericStrings()

Dim rngTemp As Range
Dim strTemp As String
Dim currNumber1 As Currency
Dim currNumber2 As Currency
Dim lngTemp As Long
Dim lngPos As Long
Dim lngLastRow As Long

    With ActiveSheet

    lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For Each rngTemp In .Cells(1, "A").Resize(lngLastRow, 1) ' Set Range to look at
        strTemp = rngTemp.Value2 ' Get string value of each cell
        lngTemp = Len(strTemp) 'Get length of string
        currNumber1 = 0 ' Reset value
        currNumber2 = 0 ' Reset value
        ' Get first number
        currNumber1 = fncGetNumericValue(strTemp, 1) ' Strip out first number
        ' Get second number if exists
        ' First strip out first number
        strTemp = Replace(strTemp, currNumber1, "")
        If Len(strTemp) <> 0 Then
            currNumber2 = fncGetNumericValue(strTemp, 1)
        End If

    ' now paste to sheet

        If currNumber1 <> 0 And currNumber2 <> 0 Then
            rngTemp.Offset(0, 1).Value = currNumber1 + currNumber2
            rngTemp.Offset(0, 2).Value = "sum of the numbers"

        ElseIf currNumber1 <> 0 Then
            rngTemp.Offset(0, 1).Value = currNumber1

        End If

        Next rngTemp

    End With

    Call MsgBox("Procedure Complete!", vbOKOnly + vbInformation, "Procedure Complete")

End Sub



Private Function fncGetNumericValue(strTemp As String, lngStart As Long) As Currency

Dim varTemp As Variant
Dim lngCount As Long
Dim lngTemp As Long

' Reset

lngCount = 1
lngTemp = 1
varTemp = ""

On Error Resume Next

If IsNumeric(Left(strTemp, lngCount)) Then
    Do While IsNumeric(Left(strTemp, lngCount)) = True
    varTemp = Left(strTemp, lngCount)
    lngCount = lngCount + 1

    If lngCount > Len(strTemp) Then
        Exit Do
        End If
        Loop
    Else
        ' First clear non-numerics from string
        lngTemp = 1
        Do While IsNumeric(Left(strTemp, 1)) = False
        lngTemp = lngTemp + 1
        strTemp = Mid(strTemp, 2, Len(strTemp) - 1)
            If lngTemp > Len(strTemp) Then
                Exit Do
            End If
        Loop

        ' Then extract second number if exists

        If strTemp <> "" Then
        Do While IsNumeric(Mid(strTemp, lngCount, 1)) = True
        varTemp = Left(strTemp, lngCount)
        lngCount = lngCount + 1
            If lngCount > Len(strTemp) Then
                Exit Do
            End If
Loop
        End If
    End If

    ' Retrun Value

    If IsNumeric(varTemp) Then
        fncGetNumericValue = CCur(varTemp)
    Else
        fncGetNumericValue = 0
    End If

 End Function

这是我想要做的： https://www.youtube.com/watch?v=EjHnJVxuWJA

我对VBA的了解非常有限，因此，如果我提出任何愚蠢的问题，请原谅。成功运行该程序将节省我很多时间。谢谢！

Answer 1

类似这样的东西：

Private Sub extract_num()

   Dim cell as Range
   Dim ws as Worksheet: Set ws = Sheets("Sheet1") ' replace Sheet1 with ur sheet name
   Dim lr as Long: Set lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
   Dim values() As String
   Dim i as Byte
   Dim temp as Double

   For Each cell in ws.Range("A2:A" & lr)

      If Not isEmpty(cell) Then
           values = Split(cell, " ")
           For i = LBound(values) to UBound(values)
              values(i) = Replace(values(i), ",", ".")
              If isNumeric(values(i)) Then
                  temp = temp + values(i)
              End If
           Next i
           cell.Offset(0, 2) = temp
           temp = 0
      End If

   Next cell

End Function

这是假定的：

a）各个单词和数字始终用空格"123 abc 321"
b）逗号“ ,”用作算术浮点分隔符##,##

Answer 2

与Rawrplus略有不同的方法

Option Explicit

Sub UpdateTotals()

    Dim aRawValues As Variant
    Dim iLRow&, iRow&, iArr&
    Dim dTotal#

    With ThisWorkbook.Worksheets("Sheet1")  '<-- Change the sheet name to your sheet

        iLRow = .Cells(Rows.Count, 1).End(xlUp).Row                 ' Get row count

        For iRow = 1 To iLRow                                       ' Loop through all rows in the sheet

            aRawValues = Split(.Range("A" & iRow).Value, " ")       ' Create and array of current cell value

            For iArr = LBound(aRawValues) To UBound(aRawValues)     ' Loop through all values in the array

                dTotal = dTotal + ReturnDouble(Replace(aRawValues(iArr), ",", "."))     ' Add the returned double to total

            Next

            .Range("B" & iRow).Value = dTotal                       ' Set value in column B
            dTotal = 0#                                             ' Reset total

        Next

    End With

End Sub


Function ReturnDouble(ByVal sTextToConvert As String) As Double

    Dim iCount%
    Dim sNumbers$, sCurrChr$

    sNumbers = ""
    For iCount = 1 To Len(sTextToConvert)
        sCurrChr = Mid(sTextToConvert, iCount, 1)
        If IsNumeric(sCurrChr) Or sCurrChr = "." Then
            sNumbers = sNumbers & sCurrChr
        End If
    Next

    If Len(sNumbers) > 0 Then
        ReturnDouble = CDbl(sNumbers)
    Else
        ReturnDouble = 0#
    End If

End Function

如何从字符串中提取数字，如果有多个，则将它们加在一起？

2 个答案: