1

我需要完成以下工作：

前

变成

后

基本上在数字标题之间插入空格（1.0、1.1、1.2，如果不存在则插入空格......）

并且如果一个数字不存在，添加它。（如“之前”图片中缺少 2.0 和 6.0）

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

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）

只需要一些建议或如何操作数据以实现目标的示例。非常感谢。任何帮助表示赞赏。

4

3 回答 3

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
于 2013-09-06T15:18:59.893 回答
2

您的想法在数据管理/迭代方面似乎或多或少清晰，尽管您为这个特定问题选择的方法对我来说似乎不是理想的方法。我宁愿依赖 Excel 单元格而不是数组（能够存储更多信息，易于复制并且具有与您可以关联的目标格式等效的结构）。就解释所有必需的更改而言不太容易，我更喜欢写下一个算法来执行你想要的操作（具有讽刺意味的是，在不久前批评了这个过程之后:)）。请记住，此代码依赖于“临时列”（默认为 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

注意：不建议创建太大的数组。确切的限制取决于计算机的能力（它的内存）和当前条件（正在运行的进一步程序）。另外应该指出的是，我过去确实遇到过一些使用 VBA 和大阵列的问题，因此我更愿意在这里更加谨慎。一般来说（在任何编程语言中），我很少声明大小超过 5000 的一维数组。

注意2：从性能的角度来看，读取/写入 Excel 单元格是一种非常糟糕的方法。我一般不建议依赖它（甚至默认情况下也不建议）。我认为在这些特定条件下这是一个好主意：输入数据的大小不明确以及描述 OP 可能能够轻松关联的方法。我个人会依赖数组，并且在一定大小上依赖临时文件（比从 Excel 读取/写入快得多）。

于 2013-09-06T14:33:27.723 回答
0

这是我的宏的版本供参考。我在案例选择中引用命名常量。

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
于 2013-09-06T17:29:20.163 回答