Приведенный ниже макрос преобразует входные данные в указанный вами формат. Надеемся, что остальные записи вашего набора данных будут иметь аналогичную структуру, иначе, конечно, есть место для изменений.
Я не совсем уверен насчет ~
знака, как он появляется на входе, но не в вашем дальнейшем описании. Это может быть решено путем изменения startString
переменной.
Option Explicit Sub transpose() Dim i As Long Dim noOfRows As Long Dim bc As String 'blank cell replacement Dim startString As String Dim endString As String Dim record As String Dim j As Long 'where to print record - row number Const c As Long = 3 'where to print record - column number Dim sheetname As String Dim currentCellValue As String Dim previousCellValue As String 'it is used to ignore multiple consecutive empty cells startString = "~#[" endString = "]" bc = " " j = 1 sheetname = ActiveSheet.Name 'number of rows used in s/s including blanks in between For i = Worksheets(sheetname).Rows.Count To 1 Step -1 If Cells(i, 1).Value <> "" Then Exit For End If Next i noOfRows = i 'loop through all rows For i = 1 To noOfRows currentCellValue = Cells(i, 1).Value 'check if startsWith If InStr(Trim(currentCellValue), startString) = 1 Then record = currentCellValue 'check if endsWith ElseIf Len(Trim(currentCellValue)) > 0 And Len(Trim(currentCellValue)) = InStrRev(Trim(currentCellValue), endString) Then record = record + currentCellValue 'prints output records to the worksheet Cells(j, c).Value = record j = j + 1 Debug.Print record ElseIf Len(Trim(currentCellValue)) = 0 And Len(Trim(previousCellValue)) > 0 Then record = record + bc 'non blank cells which are between start and end strings ElseIf Len(Trim(currentCellValue)) > 0 Then record = record + currentCellValue End If previousCellValue = currentCellValue Next i End Sub