Ігор Гончаренко написал: Сергей Верухин, вы не мытарства свои описывайте в попытке найти решение, а описывайте задачу написали ОДНУ! фразу: Шумоглушитель SHK 160/6 я написал как ее разделить я не знаю что там у вас еще быввает на сколько частей и как его поделить это-то понимаете? что я не могу угадать с написанием макроса не имея представления, а что там может быть в данных
Ігор Гончаренко, дело в том, что я попросил сделать разделение только по одному условию, чтобы дальше решить задачу своими силами. Если бы я хотел получить готовое решение моей задачи, я бы описывал все подробно, как в нормальном ТЗ. Но я не хочу получить готовое решение на все, потому что тогда не научусь сам. Вы мне дали направление, я его пытался применить самостоятельно, дополнив некоторыми параметрами и условиями. Я попробовал самостоятельно сделать, у меня не вышло и поэтому я снова обратился к Вам. В этом все и дело (
[URL=#]?[/URL] 1 2 3 4 5 6 7 8 9 10 11 12 13 14 Sub SplitNoLatino() Dim r&, re, ms, s$ Set re = CreateObject( "VBScript.RegExp" ) re.Pattern = "[А-Яа-яЁё ]+" : r = 1 Do While Not IsEmpty(Cells(r, 1)) s = Cells(r, 1) If re.test(s) Then Set ms = re.Execute(s) Cells(r, 3) = Trim(ms(0)) Cells(r, 4) = Right(s, Len(s) - Len(ms(0))) End If r = r + 1 Loop End Sub
Этот способ работает отлично, но есть некоторые нюансы, решить которые не могу уже пару часов. Пытался условие дополнительное ввести - не работает. Пытался через переменные, тоже не работает. Мой код ниже. Пытаюсь сделать исключение, т.к. не все позиции нужно разделять, а если точнее, то вот:
Код
Sub SpliTest()
Dim r&, re, ms, s$
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "[А-Яа-яЁё ]+": r = 26
Do While Not IsEmpty(Cells(r, 2))
If ActiveCell Like "*" & "Установка" & "*" Or ActiveCell Like "*" & "Приточная" & "*" Or ActiveCell Like "*" & "Вытяжная" & "*" _
Or ActiveCell Like "*" & "id" & "*" Then
r = r + 1
GoTo Prodoljit
End If
s = Cells(r, 2)
If re.test(s) Then
Set ms = re.Execute(s)
Cells(r, 2) = Trim(ms(0))
Cells(r, 3) = Right(s, Len(s) - Len(ms(0)))
End If
Prodoljit:
r = r + 1
Loop
End Sub
Собственно, ячейки, в которых есть текст "Установка, Приточная, Вытяжная, id..." разделять не нужно.
Обратный клапан DV-K100 OK нужно делить. П2 (ОАСС) id2440491 Приточная установка DV-B05000 R /[P1]-[K1]-[F1]-[SVH-W.3]-[V1.КЦ31С (1.1/3000)]-[H1]-[P1] - не нужно.
Повторяются в неделимых ячейках обычно слова, написанные выше. (для примера)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, прикрепил файлы, в которых видно, что и как нужно сделать.
Небольшое уточнение по задаче, которую макрос должен по итогу выполнять: 1. Строк может быть от 5 и до 1000-5000 штук. Эта цифра всегда разная. Самостоятельная остановка, как только заканчиваются данные в таблице 2. Макрос должен делить только те значения, которые указаны на примере ниже: - остальные должен игнорировать До: После:
'Option Base 1
Option Explicit
'Option Private Module
'==================================================================================================
Sub Splitter()
Dim rng As Range
Dim x, arr, aCrit(), aOne(1 To 1, 1 To 1)
Dim tx$, t!, r&, m&, nSpl&, f As Boolean
t = Timer
Set rng = [a2:a88]: arr = rng.Value2
ReDim Preserve arr(1 To UBound(arr, 1), 1 To 2)
aCrit = Array("шумоглушитель *", "гибкая вставка *", "вентилятор канальный *", "обратный клапан *", "регулятор скорости *")
For r = 1 To UBound(arr, 1)
tx = LCase$(Trim(arr(r, 1)))
For Each x In aCrit
If tx Like x Then f = True: Exit For
Next x
If f Then
f = False: nSpl = nSpl + 1: m = Len(x)
arr(r, 2) = Trim(Mid$(arr(r, 1), m)): arr(r, 1) = Trim(Left$(arr(r, 1), m - 2))
End If
Next r
If nSpl = 0 Then MsgBox "Строк для разделения НЕ НАЙДЕНО!", vbExclamation, "Время работы: " & Format$(Timer - t, "0.00 сек"): Exit Sub
rng.Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr
MsgBox "Разделено строк: " & Format$(nSpl, "#,##0") & " из " & UBound(arr, 1), vbInformation, "Время работы: " & Format$(Timer - t, "0.00 сек")
End Sub
'==================================================================================================
'==================================================================================================
даблклик по А1 запускает макрос, по С1 — переносит данные из третьего столбца в первый (чтобы повторить)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Jack Famous, перенес себе в макрос, все работает как часы. Спасибо огромнейшее! Пойду теперь разбираться, что в этом макросе за что отвечает и как он вообще функционирует. Много неизвестных команд
Сергей Верухин, пожалуйста Спрашивайте, если что непонятно будет
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄