如何parsing包含xxx的单元格的一部分,并将数据复制到另一个单元格?

我有一个Excel文件,我想parsingD列中的每个单元格的开始,并复制和粘贴在单元格(相同的行,列B)的数字我如何parsing数字0到9和“。 并将该值xxxx复制到列B? D列的单元格起始处没有多less个数字和句点的标准格式,可以是1.3.4或1.3.4。 或1.3 ect …

===================================================================== '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 =========================== 

Excel Sheet的图片

编辑:现在与解释什么代码的意见

显然你不需要你的真人版的评论。

将下面的代码粘贴到一个新的模块,然后用它作为一个WorksheetFunction(我猜测应该调用什么函数)。 在任何单元格中,input=ExtractOutline(<cell address>) ,其中<cell address>是要从中提取xxx位的单元格。

 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 

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

 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 

像这样的东西

您可以在这里看到RegExp示例

 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