0

В общем, у меня есть некоторые строки, в которых находятся словосочетания, разделённые #. Выглядит примерно так: голубое небо#зелёная трава#оранжевые апельсины#апельсиновая оранжевость Мне нужно, чтобы когда скрипт наткнётся на # в ячейке, он переносил оставшееся на строку ниже, снова натыкался, снова на строку ниже. И так до тех пор, пока # не останется. То есть, чтобы 4 словосочетания через # таким образом в итоге давали 4 строки.

Если это невозможно средствами языка, тогда как узнать порядковый номер символа в ячейке? Я так обрежу.

1
  • Идете по строкам и проверяете на условие InStr("Tech on#the Net", "T")>0 -> Result: 8, затем функцией LEFT() вырезаете часть строки до найденного символа и RIGHT() после в этой части повторяете InStr. Затем вставляете Worksheets.Rows(row#).Insert строк сколько нужно и в нужные ячейки вырезанные LEFT()'ом строки 25 окт 2018 в 9:18

4 ответа 4

2
Sub FindSymbol()
Dim aData(), aSpl
Dim lRw As Long, i As Long, k As Long, j As Long
    With Worksheets("sheet1") ' лист с исходными данными'
        lRw = .Cells(.Rows.Count, 1).End(xlUp).Row 'последняя строка с данными в столбце А'
        aData = .Range("A1:A" & lRw).Value ' тексты заносим в массив'
    End With

    ' определяем (с запасом) размерность массива результата'
    ReDim aRes(1 To lRw * 5, 1 To 1) ' 5 - макс к-во фрагментов в текстах'

    For i = 2 To lRw ' цикл по текстам, начиная со стоки 2'
        aSpl = Split(aData(i, 1), "#")  ' расщепляем на фрагменты'

        For j = 0 To UBound(aSpl)
            k = k + 1: aRes(k, 1) = aSpl(j)  ' записываем фрагменты в массив результата'
        Next j
    Next i

    With Worksheets("sheet1") ' лист для выгрузки'
        .Columns(3).ClearContents ' чистим столбец С'
        .Range("C2").Resize(k, 1).Value = aRes ' выгружаем результат в столбец С'
    End With

    MsgBox "OK", 64, "" ' радуемся :)'
End Sub

Для выгрузки в исходный диапазон вместо последнего блока With/End With записать строку

Worksheets("sheet1").Range("A2").Resize(k, 1).Value = aRes ' выгружаем результат в столбец A'

Можно формулой.

  • Для одной ячейки, результат по строкам:

    =СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ("#"&$A$2;"#";ПОВТОР(" ";99));СТРОКА(A1)*99;99))

  • Для диапазона ячеек, результат по столбцам:

    =СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ("#"&$A2;"#";ПОВТОР(" ";99));СТОЛБЕЦ(A1)*99;99))

Хотя для разнесения по столбцам можно проще - применить инструмент

Данные-Текст_по_столбцам-С_разделителем

  • Для диапазона ячеек, результат по строкам.

В доп. столбце находим количество фрагментов для подсказки основной формуле: в первой строке диапазона - 1, ниже формула

=ДЛСТР(A2)-ДЛСТР(ПОДСТАВИТЬ(A2;"#";))+1+B2

Результат:

=СЖПРОБЕЛЫ(ПСТР(ПОДСТАВИТЬ("#"&ИНДЕКС($A$2:$A$20;ПОИСКПОЗ(СТРОКА(A1);$B$2:$B$20));"#";ПОВТОР(" ";99));(СТРОКА(A1)-ИНДЕКС($B$2:$B$20;ПОИСКПОЗ(СТРОКА(A1);$B$2:$B$20))+1)*99;99))

введите сюда описание изображения

1
  • Спасибо. Я уже нашёл решение наилучшим образом удовлетворяющее мои потребности. 26 окт 2018 в 4:06
1
Sub split_by_diez()
Dim tmp As Range, cnt As Integer
Set tmp = ActiveSheet.Range("A1") ' Первая ячейка колонки
cnt = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
Do Until tmp.Row > cnt
    If InStr(tmp.Value, "#") Then
        tmp.Insert xlShiftDown
        tmp.Offset(-1, 0).Value = Left(tmp.Value, InStr(tmp.Value, "#") - 1)
        tmp.Value = Mid(tmp.Value, InStr(tmp.Value, "#") + 1)
        cnt = cnt + 1
    Else
        Set tmp = tmp.Offset(1, 0)
    End If
Loop
End Sub
1
  • Спасибо. Я уже нашёл решение наилучшим образом удовлетворяющее мои потребности. 26 окт 2018 в 4:05
1
Sub Проверить_Строки()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("Лист1")
nRow = sh.Cells(sh.Rows.Count, 1).End(xlUp).Row 'в первом столбце последняя не пустая строка
'бежим по столбцу и ищем ячеики со знаком #
For i = nRow To 1 Step -1
    If InStr(1, sh.Cells(i, 1), "#") > 0 Then
        masStr = Split(sh.Cells(i, 1), "#")
        For k = 0 To UBound(masStr)
            If k = 0 Then
                sh.Cells(i, 1).FormulaR1C1 = masStr(k)
            Else
                sh.Rows(i + k).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove 'добавляем пустую ниже
                sh.Cells(i + k, 1).FormulaR1C1 = masStr(k)
            End If
        Next
    End If

Next
end sub
2
  • 1
    пример файла yadi.sk/d/XXdPv1t9WUIgWg
    – SergeyE
    25 окт 2018 в 11:02
  • Спасибо. Я уже нашёл решение наилучшим образом удовлетворяющее мои потребности. 26 окт 2018 в 4:05
0

Всем ответившим спасибо, ваши варианты с 90% вероятностью работают, но я полагаю, что чем проще код, тем лучше. Поэтому нашёл для себя лучшее решение. Его и прилагаю.

Sub Sabaqa()
Dim array1() As String
Dim posStr As Long
Dim r As Integer
posStr = Cells(1, 1).End(xlDown).Row
r = posStr
Range("B1").value = posStr
For i2 = 1 To posStr
    var = ActiveCell.value
    array1 = Split(var, "#")
    arvalue = UBound(array1)

    For i = 0 To arvalue
        ActiveCell.value = array1(i)
        ActiveCell.Offset(1, 0).Select
        Selection.EntireRow.Insert
    Next i
Selection.EntireRow.Delete
Next i2
6
  • ваши варианты с 90% вероятностью работают Пожалуйста, подтвердите конкретными примерами не-работы оставшиеся 10%.
    – Akina
    26 окт 2018 в 4:36
  • Прошу не путать 90% случаев и 90% вероятности. Я говорю это к тому, что я их не тестил, но почти полностью уверен что они рабочие. 27 окт 2018 в 3:44
  • "Пастернака не читал, но осуждаю!"...
    – Akina
    29 окт 2018 в 4:50
  • Да кто осуждает-то? Я просто допускаю, что один или несколько вариантов работать не станут. ДО-ПУ-СКА-Ю. Я не говорю, что они убогие и не работают. Я не осуждаю их. Решительно не понимаю, почему Вы так уверены, что я априори настроен против Вас. 30 окт 2018 в 6:19
  • Я не говорю о настрое. Я о том, что технический специалист должен оперировать проверенными фактами, а не облыжными домыслами.
    – Akina
    30 окт 2018 в 6:26

Ваш ответ

By clicking “Отправить ответ”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Всё ещё ищете ответ? Посмотрите другие вопросы с метками или задайте свой вопрос.