如何解析包含 x.x.x 的单元格的一部分。并将数据复制到另一个单元格？

Question

我有一个 excel 文件我想解析 D 列中每个单元格的开头，然后复制并粘贴单元格中的数字（同一行，B 列） 如何解析数字为 0 到 9 和“。”的单元格并将该值 x.x.x.x 复制到 B 列？在 D 列的单元格开头没有多少数字和句点的标准格式。它可以是 1.3.4 或 1.3.4。或 1.3 等...

===================================================================== 
'DIMENSIONING VARS AND PATHS
Dim Level As Range
Dim i, j, q(1 To 50) As Long
Dim numofchar As Long
Dim filepath As String
Dim filename As String
Dim PN As String
Dim HEADERrowcallout As Long
Dim LASTREQrowcallout As Long
Dim REQTEXTcolumncallout As String
Dim x As Long
Dim s As String
Dim count As Long
Dim Reqtext As Variant
Dim SectionText As Variant
'

'scanf(Input the correct row and column numbers). Used for determining start and endpoints of filtering files
HEADERrowcallout = InputBox("What row number are your headers in?")
LASTREQrowcallout = InputBox("What row number are your headers in?")
REQTEXTcolumncallout = InputBox("What is the column letter where ReqText is located? (A=1,B=2,D=4,ect...)")
'REQTYPEcolumncallout = InputBox("What is the column number from the left where the outline level is located? (A=1, B=2, ect...)")
'SECTIONcolumncallout = InputBox("What is the column number from the left where the outline level is located? (A=1, B=2, ect...)")
'


'stop screen updating
Application.ScreenUpdating = False
'

'show gridlines
ActiveWindow.DisplayGridlines = True
'

'Requirement Text to Section Maker --- Part (1)
'Part 1 filter string for the section number. (Numbers 1-10 & . until letters or space)
'Generate a string using the numbers and letters, ex [1.1.3.], cut & copy data to section column same row
For i = HEADERrowcallout + 1 To LASTREQrowcallout

    'Get length of active cell. This is max that copied cell will be

    LengthCell = Len(Cells(HEADERrowcallout + 1, REQTEXTcolumncallout))
    SectionText = (LengthActiveCell)
    Reqtext = (LengthActiveCell)

        'while count != length, scan each array position from 0 until array position value != 1-10 or .
        While x < LengthActiveCell
            Select Case Cells()
            Case "1", "2", "3", "4", "5", "6", "7", "8", "9", "0", "."
            Dim count As Long
            x = x + 1

        'If no more letters or .s, move to next cell
            x = LengthCell
    'if SectionText() = SectionText(0)

    'Keep going down ReqText column until specified end
    HEADERrowcallout = HEADERrowcallout + 1


End Sub
===========================

Picture of Excel Sheet

Answer 1

编辑：现在用 cmets 解释代码的作用

显然，您的实时版本中不需要 cmets。

将下面的代码粘贴到一个新的Module中，然后将其用作WorksheetFunction （我猜测应该调用什么函数）。在任何单元格中，输入=ExtractOutline(<cell address>)，其中<cell address> 是您希望从中提取x.x.x 的单元格。少量。

Function ExtractOutline(strInput As String)

    'Function iterates through the input string until we get to a
    'character which isn't one in "0123456789." Each character which is
    'one of these is added to the output as we go along

    Dim strOut As String        'The output we're building
    Dim intPos As Integer       'The position we've reached in the input
    Dim str1Char As String      'The character found at the current position

    intPos = 1     'We'll start at the first character
    str1Char = Mid(strInput, intPos, 1)       'Extract the intPos-th character, in this case, the 1st.

    While intPos <= Len(strInput) And WorksheetFunction.Find(str1Char, "0123456789." & str1Char) < 12

    'While
    'intPos <= Len(strInput) 
    'This makes sure we haven't iterated beyond the end of the input

    'AND
    'WorksheetFunction.Find(str1Char, "0123456789." & str1Char) < 12
    'Looks for the current character in "0123456789."
    'If it wasn't found we'd get an error (as output to the function)
    'To prevent that add current character to end of "0123456789."
    'Since "Find" returns the position, within the string,
    'and "01234567890." as 11 characters, we only match the right bit if it
    'is found before the 12th character

    'Add the character to the output
    strOut = strOut & Mid(strInput, intPos, 1)

    'Increment ready for next time round the loop
    intPos = intPos + 1
    'Get the next character to be checked
    str1Char = Mid(strInput, intPos, 1) 

    Wend

    ExtractOutline = strOut

End Function

Answer 2

或者您可以将以下方法合并到您的代码中...

Sub Alex()
Dim lr As Long
Dim rng As Range, cell As Range
Dim RE As Object
Dim Match As Object

lr = Cells(Rows.Count, 4).End(xlUp).Row
Set rng = Range("D2:D" & lr)
Set RE = CreateObject("VBScript.RegExp")

RE.Pattern = "([0-9]\.){1,}"

For Each cell In rng
If RE.test(cell.Value) = True Then
   Set Match = RE.Execute(cell.Value)
   cell.Offset(0, -2).Value = Left(Match(0), Len(Match(0)) - 1)
End If
Next cell
End Sub

Answer 3

像这样的

您可以查看 RegExp 示例 here

代码

Sub EddieBetts()

Dim rng1 As Range
Dim lngCnt As Long
Dim objRegex As Object
Dim X

Set rng1 = Range([d2], Cells(Rows.Count, "D").End(xlUp))
X = rng1.Value2
Set objRegex = CreateObject("VBScript.RegExp")
objRegex.Pattern = "([0-9\.])+"

For lngCnt = 1 To UBound(X, 1)
    If objRegex.test(X(lngCnt, 1)) Then X(lngCnt, 1) = objRegex.Execute(X(lngCnt, 1))(0)
Next

rng1.Offset(0, -2).Value2 = X

End Sub