我应该如何使用vba完成这个复杂的stringreplace？

我需要完成以下内容：

变

基本上插入数字标题之间的空间（1.0,1.1,1.2，插入空间，如果一个不存在…）

而且，如果一个数字不存在，则将其添加进去（如在“之前”图片2.0和6.0中缺失）

我想出了如何创build一个数组来检查数据，如下所示：

Dim myRange As Range, c As Range Dim x As Integer, i As Integer, arSize As Integer, y As Integer Dim myArray() As String x = 1 arSize = Int(Range("B" & Rows.Count).End(xlUp).Row) ReDim myArray(1 To arSize) Set myRange = Range("B1", Cells(Rows.Count, "B").End(xlUp)) For Each c In myRange If IsEmpty(c) = True Then myArray(x) = 0 Else If IsNumeric(Left(c, 1)) = True Then myArray(x) = Val(Left(c, 1)) Else: myArray(x) = -1 End If End If x = x + 1 Next 'for debugging: For i = 1 To UBound(myArray) Range("F" & i).Value = myArray(i) Next i End Sub 

（如果第一个字符是一个数字，则将该数字添加到数组元素中;如果它不是数字，则将该元素设置为-1，如果为空，则将该元素设置为0）

只需要一些build议，或者如何操纵数据来达到我的目标。 非常感谢你。 任何帮助赞赏。

Answer 1

您的想法似乎在数据pipe理/引用方面或多或less都很清晰，尽pipe您为这个特定问题select的方法对我来说似乎并不理想。 我宁愿依赖Excel单元而不是数组（能够存储更多的信息，容易被复制，并且具有与您可以涉及到的目标格式等效的结构）。 至于解释所有需要的改变并不是太容易，我更愿意写下一个执行你想要的操作的algorithm（具有讽刺意义的是，在不久之前批评了这个程序之后:)）。 请记住，该代码依赖于“临时列”（默认为C）来存储所有更改，在整个过程完成后清除。 请随时询问任何不清楚的地方（我发布这个是为了了解一切，不仅仅是为了执行它）。

 Dim col2 As String: col2 = "C" Dim firstRow As Integer: firstRow = 2 Set myRange = Range("B" & firstRow, Cells(Rows.Count, "B").End(xlUp)) Dim prevIndex As Integer: prevIndex = 1 Dim curRow As Long: curRow = firstRow - 1 For Each c In myRange curRow = curRow + 1 Dim consecutive As Integer: consecutive = 0 If Not IsEmpty(c) Then Dim written As Boolean: written = False Dim numRightBefore As Boolean: numRightBefore = False If IsNumeric(Left(c, 1)) = True Then Dim curIndex As Integer: curIndex = CInt(Left(c, 1)) If (curIndex <> prevIndex) Then If (curIndex < prevIndex) Then 'Something went wrong Exit For Else If (curIndex = prevIndex + 1) Then 'Normal situation -> consecutive index prevIndex = curIndex If (consecutive <> 0) Then Range(col2 & curRow).Value = "" curRow = curRow + 1 End If Else Do While (curIndex > prevIndex + 1) If (consecutive = 0) Then Range(col2 & curRow).Value = "" consecutive = 1 Else curRow = curRow + 1 End If prevIndex = prevIndex + 1 Range(col2 & curRow).Value = CStr(prevIndex) & ".0 text" curRow = curRow + 1 Loop prevIndex = prevIndex + 1 Range(col2 & curRow).Value = "" curRow = curRow + 1 End If End If End If End If If (Not written) Then Range(col2 & curRow).Value = c.Value End If consecutive = curIndex End If Next Range(col2 & firstRow & ":" & col2 & curRow).Copy myRange.PasteSpecial Range(col2 & firstRow & ":" & col2 & curRow).Clear 

注： 不build议创build太大的数组 。 确切的限制取决于计算机的function（其内存）和当前条件（正在运行的其他程序）。 另外值得注意的是，在过去的VBA和大arrays中，我确实遇到过一些问题，所以我更愿意在这里更加谨慎。 一般来说（在任何编程语言中），我很less声明一个尺寸大于5000的一维数组。

注2：从性能angular度来看， 读取/写入Excel单元格是一个非常糟糕的方法。 我不build议一般依靠这个 （甚至不默认）。 我认为在这些具体条件下这是一个好主意：input数据的大小不明确，并描述了OP可能容易涉及的方法。 我个人会依赖于数组，并超过一定的大小临时文件（比从Excel读取/写入快得多）。

Answer 2

 Sub tgr() Dim arrLines() As String Dim varLine As Variant Dim varLineStart As Variant Dim LineIndex As Long Dim lCounter As Long Dim lInterval As Long lCounter = 1 lInterval = 5000 ReDim arrLines(1 To lInterval) For Each varLine In Range("B2", Cells(Rows.Count, "B").End(xlUp)).Value LineIndex = LineIndex + 1 varLineStart = Trim(Left(Replace(Trim(varLine), " ", String(99, " ")), 99)) If IsNumeric(varLineStart) Then varLineStart = Int(varLineStart) If varLineStart > lCounter Then lCounter = lCounter + 1 Do While varLineStart > lCounter If Len(arrLines(LineIndex - 1)) = 0 Then If LineIndex > UBound(arrLines) Then ReDim Preserve arrLines(1 To UBound(arrLines) + lInterval) arrLines(LineIndex) = lCounter & ".0 text" lCounter = lCounter + 1 LineIndex = LineIndex + 1 End If LineIndex = LineIndex + 1 Loop If Len(arrLines(LineIndex - 1)) > 0 Then LineIndex = LineIndex + 1 End If End If If LineIndex > UBound(arrLines) Then ReDim Preserve arrLines(1 To UBound(arrLines) + lInterval) arrLines(LineIndex) = varLine Next varLine If LineIndex > 1 Then ReDim Preserve arrLines(1 To LineIndex) Range("C2").Resize(LineIndex).Value = Application.Transpose(arrLines) End If Erase arrLines End Sub 

Answer 3

这里是我的macros的版本供参考。 我在case select中引用了命名常量。

 Sub varocarbas() Dim col2 As String: col2 = "C" Dim firstRow As Integer: firstRow = 2 Set myRange = Range("B" & firstRow, Cells(Rows.Count, "B").End(xlUp)) Dim prevIndex As Integer: prevIndex = 1 Dim curRow As Long: curRow = firstRow - 1 For Each c In myRange curRow = curRow + 1 Dim consecutive As Integer: consecutive = 0 If Not IsEmpty(c) Then Dim written As Boolean: written = False Dim numRightBefore As Boolean: numRightBefore = False If IsNumeric(Left(c, 1)) = True Then Dim curIndex As Integer: curIndex = CInt(Left(c, 1)) If (curIndex <> prevIndex) Then If (curIndex < prevIndex) Then 'Something went wrong Exit For Else If (curIndex = prevIndex + 1) Then 'Normal situation -> consecutive index prevIndex = curIndex If (consecutive <> 0) Then Range(col2 & curRow).Value = "" curRow = curRow + 1 End If Else Do While (curIndex > prevIndex + 1) If (consecutive = 0) Then Range(col2 & curRow).Value = "" consecutive = 1 Else curRow = curRow + 1 End If prevIndex = prevIndex + 1 Dim sHeading As String Select Case prevIndex Case 1 sHeading = cIN Case 2 sHeading = cTL Case 3 sHeading = cPP Case 4 sHeading = cRF Case 5 sHeading = cPL Case 6 sHeading = cPM Case 7 sHeading = cPR Case 8 sHeading = cRS Case 9 sHeading = cCP End Select Range(col2 & curRow).Value = CStr(prevIndex) & ".0 " & sHeading curRow = curRow + 1 Loop prevIndex = prevIndex + 1 Range(col2 & curRow).Value = "" curRow = curRow + 1 End If End If End If End If If (Not written) Then Range(col2 & curRow).Value = c.Value End If consecutive = curIndex End If Next Range(col2 & firstRow & ":" & col2 & curRow).Copy myRange.PasteSpecial Range(col2 & firstRow & ":" & col2 & curRow).Clear End Sub