Как я могу выполнить эту сложную замену строки с помощью vba?

Question

мне нужно выполнить следующее:

становится

В основном вставлять пробелы между числом заголовков (1.0, 1.1, 1.2, вставьте пробел, если не существует ...)

А также, если число не существует, добавьте его. (Как в изображении 'before' 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)

Просто попросите совета или пример того, как я могу манипулировать данными для достижения моей цели. Большое спасибо. Любая помощь оценивается.

Answer 1

Ваши идеи кажутся более или менее ясными на фронтах управления данными/документами, хотя подход, выбранный вами для этой конкретной проблемы, не кажется идеальным для меня. Я предпочел бы полагаться на ячейки 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 и большими массивами, поэтому я предпочитаю быть более осторожным здесь. В общем случае (на любом языке программирования), я редко объявить 1D массив с размером выше, чем 5000.

Примечание2: чтения/записи в ячейки Excel является, с точки зрения производительности, довольно плохой подход. Я не рекомендую полагаться на это вообще (даже не по умолчанию). Я думал, что это хорошая идея в этих конкретных условиях: нечеткий размер входных данных и отображение подхода, к которому 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

Вот версия моего макроса для справки. Я ссылаюсь на именованные константы в случае выбора.

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