Excel VBA：从字母数字中获取数值
我有一列（a列）有字母数字文本，我想读它并把它写回另一列（C列）。代码是Excel VBA：从字母数字中获取数值,vba,excel,Vba,Excel,我有一列（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
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
修改数据部分，我只想从文本中获取值。我是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使用我提出的：
=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")
这为我提供了所提供示例的预期结果。使用我得出的结果：
=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")
这为我提供了所提供示例的预期结果。为了完成此任务，您需要添加其他函数，这将使代码更简单、更清晰：
首先，函数只从给定字符串中提取数字：
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，用于复制：
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
为了完成这项任务，您需要添加其他功能，这将使代码更简单、更清晰：
首先，函数只从给定字符串中提取数字：
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，用于复制：
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
也可以使用以下数组公式（CTRL+SHIFT+ENTER）
=文本（最大值（中间（“&A3，行（$A$1:$A$99），列（$A$1:$CU$1））+0,0）），“000”）
注意：公式限制为99个字符，但如果存在超过99个字符的单元格，则可以轻松扩展为99个字符
也可以使用以下数组公式（CTRL+SHIFT+ENTER）
=文本（最大值（中间（“&A3，行（$A$1:$A$99），列（$A$1:$CU$1））+0,0）），“000”）
注意：公式限制为99个字符，但如果存在超过99个字符的单元格，则可以轻松扩展为99个字符
我会用不同的方法来处理宏
- 将原始数据读入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+
+
-
\D*
*
（\d+）
\d+
+
使用创建宏时，我会使用稍微不同的宏
- 将原始数据读入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+
+
-
\D*
*
（\d+）
\d+
+
创建时使用如果在一列中我们有Adapa S11或R1 Adapa S2500怎么办？@MichałTurczyn for Adapa S11将给出结果011。数据最多只有3位数字。但是，如果超过3，则为2500。但是，我确信该值最多只有3位。如果在列中有Adapa S11或R1 Adapa S2500会怎么样？Adapa S11的@MichałTurczyn将给出结果011。数据最多只有3位数字。但是，如果超过3，则为2500。但是，我确信该值最多只有3位。请原谅我的问题，我是否需要将函数添加到我的代码中或为答案创建新模块？我确实理解函数
，但我没有理解您在CopySpecial
@MohamadFaisal上的最后一部分。您可以将其全部放在一个模块中。请原谅我的问题，我需要将函数添加到我的代码中还是创建新模块来获得答案？我确实理解函数
，但我没有理解你在CopySpect
@MohamadFaisal上的最后一部分。你可以把它全部放在一个模块中。