Excel-VBA：从字母数字中获取数值

Question

我有一个列（列A），其中包含字母数字文本，我想读取它并将其写回另一列（C列）。代码是;

Sub getnumber()

'Define Variable
Dim anicode As Variant
Dim n As Long
Dim lastrowdata As Long

'Data Location
Sheets("Sheet1").Activate
lastrowdata = range("A2").end(xlDown).Row - 1

'Redefine Array
ReDim anicode(lastrowdata)

'Read Data
For n = 1 To lastrowdata
  anicode(n) = Sheets("Sheet1").Cells(1 + n, 1)
Next n

'Altering Data
For n = 1 To lastrowdata
  If IsNumeric(anicode(n)) Then
     anicode(n) = NumericOnly
  Else
  End If
Next n

'Write Data
For n = 1 To lastrowdata
  Sheets("Sheet1").Cells(1 + n, 3) = anicode(n)
Next n

End Sub

我被困在Altering Data部分，我想从文本中获取价值。我只是VBA中的新手，目前只知道IsNumeric函数。 在A列中，数据是字母数字并且是随机的，其中可能有短划线（ - ）或空格（），甚至是混乱的字母表，如S2或X4。数据可能只是数字（因为数据长~8k并且将会增长）。

作为例子;在A栏中，我有

R1-Adapa S2
R2-Adapa S2
R3-Omis 14
R4-189

在C栏中，我想只有数字

R1-002
R2-002
R3-014
R4-189

感谢是否有任何可能的功能或对我的问题或我的代码的任何意见。谢谢stackoverflow.com

Answer 1

我会稍微改变一下宏

• 将原始数据读入vba宏以提高处理速度
• 使用正则表达式获取字符串的相关部分
• 将终端数字格式化为具有适当数量的前导零
• 将结果写入另一个VBA数组 - 再次为速度。
• 将结果写回并格式化回工作表。
• 根据需要格式化结果

例如：

Option Explicit
Sub getnumber()
    Dim wsSrc As Worksheet
    Dim vSrc As Variant, vRes As Variant
    Dim rRes As Range
    Dim I As Long

Set wsSrc = Worksheets("sheet1")
With wsSrc

'set results area
    Set rRes = .Cells(1, 3)

'Read data into array for faster processing
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'create results array
ReDim vRes(1 To UBound(vSrc), 1 To 1)

'Fill vres with the converted data
For I = 1 To UBound(vRes, 1)
    vRes(I, 1) = reFormat(vSrc(I, 1))
Next I

'Size the results range
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1))

'Clear the area and write the new data
With rRes
    .EntireColumn.Clear

   'In case a value is solely numeric, as in A5 of example
    .NumberFormat = "@"

    .Value = vRes
    .EntireColumn.AutoFit
    .Style = "Output"
End With

End Sub



Function reFormat(ByVal S As String) As String
    Dim RE As Object, MC As Object

Set RE = CreateObject("vbscript.regexp")
With RE
    .Global = True
    .MultiLine = True
    .Pattern = "(^\D\d+-)?\D*(\d+)"
    If .test(S) = True Then
        Set MC = .Execute(S)
        With MC(0)
            reFormat = .submatches(0) & Format(.submatches(1), "000")
        End With
    End If
End With

End Function

以下是正则表达式模式的简要说明：

（^ \ d \ d + - ）？\ d *（\ d +）

(^\D\d+-)?\D*(\d+)

选项：区分大小写; ^ $匹配在换行

• Match the regex below and capture its match into backreference number 1 (^\D\d+-)?
  • Between zero and one times, as many times as possible, giving back as needed (greedy) ?
  • Assert position at the beginning of the string ^
  • Match a single character that is NOT a “digit” \D
  • Match a single character that is a “digit” \d+
    • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +
  • Match the character “-” literally -
• Match a single character that is NOT a “digit” \D*
  • Between zero and unlimited times, as many times as possible, giving back as needed (greedy) *
• Match the regex below and capture its match into backreference number 2 (\d+)
  • Match a single character that is a “digit” \d+
    • Between one and unlimited times, as many times as possible, giving back as needed (greedy) +

使用RegexBuddy

创建

Answer 2

使用source我想出了：

=LEFT(A1,3)&TEXT(MID(SUMPRODUCT(MID(0&A1,LARGE(INDEX(ISNUMBER(--MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1))*ROW(INDIRECT("1:"&LEN(A1))),0),ROW(INDIRECT("1:"&LEN(A1))))+1,1)*10^ROW(INDIRECT("1:"&LEN(A1)))/10),2,LEN(A1)),"000")

这给出了我提供的例子的预期结果。

Answer 3

为了完成任务，您需要额外的功能，这将使代码更容易和更清洁：

首先，只提取给定字符串数字的函数：

Function OnlyNumbers(word As String) As String
    Dim i As Long, ascIdx As Long
    OnlyNumbers = ""
    For i = 1 To Len(word)
        'if it's letter then append it to a returned word
        If IsNumeric(Mid(word, i, 1)) Then
            OnlyNumbers = OnlyNumbers + Mid(word, i, 1)
        End If
    Next
End Function

第二，我们需要功能，如果需要，我们需要广告前导零：

Function LeadingZeros(word As String, outputLength As Long) As String
    Dim i As Long
    LeadingZeros = ""
    For i = 1 To outputLength - Len(word)
        LeadingZeros = LeadingZeros + "0"
    Next
    LeadingZeros = LeadingZeros + word
End Function

最后，我们写了一个副本，它进行复制：

Sub CopySpecial()
    Dim ws As Worksheet, lastRow As Long, i As Long, hyphenIdx As Long
    'always set reference to main sheet, so you can use it in range references
    Set ws = Sheets("Arkusz1")
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    For i = 1 To lastRow
        code = Cells(i, 1).Value
        hyphenIdx = InStr(1, code, "-")
        'set the text formatting, so leading zeroes won't be truncated
        Cells(i, 3).NumberFormat = "@"
        If hyphenIdx = 0 Then
            Cells(i, 3).Value = LeadingZeros(OnlyNumbers(Cells(i, 1).Value), 3)
        Else
            Cells(i, 3).Value = Mid(code, 1, hyphenIdx) + LeadingZeros(OnlyNumbers(Mid(code, hyphenIdx + 1)), 3)
        End If
    Next

End Sub

Answer 4

以下数组公式（ CTRL + SHIFT + ENTER ）也可以使用

=TEXT(MAX(IFERROR(MID(" "&A3,ROW($A$1:$A$99),COLUMN($A$1:$CU$1))+0,0)),"000")

  

注意：公式限制为99个字符，但如果存在超过99个字符的单元格，则可以轻松扩展。