Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Массовое удаление габаритов, Нужно удалить габариты в не зависимости где они стоят в ячейке.
 
#1
05.08.2022 10:59:42
Пример приложу в файле, Как возможно с помощью макросов удалить габариты ....х....х....; если они ещё и разные + убрать ; в конце и если возможно отделить цвет с большой буквы в отдельный столбец, пробовал просто разделением и как то заменой через * не выходит
 
 
 
#2
05.08.2022 11:30:27
ТУТ почитайте
 
 
 
#3
05.08.2022 11:38:42
Код
Sub RunThis()
  Dim a, b, r&, re
  a = [a1].CurrentRegion:  ReDim b(1 To UBound(a), 1 To 2)
  b(1, 1) = "должно получиться": b(1, 2) = "Цвет"
  Set re = CreateObject("VBScript.RegExp")
  For r = 2 To UBound(a)
    re.Pattern = "\d+х\d+х\d+; "
    If re.test(a(r, 1)) Then a(r, 1) = re.Replace(a(r, 1), "")
    re.Pattern = "\d+х\d+х\d+"
    If re.test(a(r, 1)) Then a(r, 1) = re.Replace(a(r, 1), "")
    re.Pattern = "; цвет:.+"
    If re.test(a(r, 1)) Then
      b(r, 2) = re.Execute(a(r, 1))(0)
      b(r, 2) = Right(b(r, 2), Len(b(r, 2)) - 8)
      Mid(b(r, 2), 1, 1) = UCase(Left(b(r, 2), 1))
      a(r, 1) = re.Replace(a(r, 1), "")
    End If
    b(r, 1) = a(r, 1)
  Next
  [d1].Resize(UBound(a), 2) = b
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#4
05.08.2022 12:16:05
Ігор Гончаренко,  а как это работает? я вставил в модуль нажал run и там ошибка была 5018
 
 
 
#5
05.08.2022 12:17:43
Ігор Гончаренко, всё получилось
 
 
 
#6
05.08.2022 12:20:56
Ігор Гончаренко, а как сделать это для массового, я запускаю макрос но тоже выдает ошибку, работает только в том файле.файл приложил
 
 
 
#7
05.08.2022 12:39:38
Ігор Гончаренко, Или возможно просто чтобы удалялись габарыты, цвет я сам уберу, а то там выходит что есть строчки где нет цвета и он ошибку выдает
 
 
 
#8
05.08.2022 12:51:10
строку
Код
      Mid(b(r, 2), 1, 1) = UCase(Left(b(r, 2), 1))

замените на
Код
      If Len(b(r, 2)) Then Mid(b(r, 2), 1, 1) = UCase(Left(b(r, 2), 1))
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#9
05.08.2022 13:04:30
Можно такой формулой:
Код
=СЖПРОБЕЛЫ(ПОДСТАВИТЬ(A2;ФИЛЬТР.XML("<t><s>"&ПОДСТАВИТЬ(СЖПРОБЕЛЫ(A2);" ";"</s><s>")&"</s></t>";"//s[translate(.,'1234567890','')!=.][contains(., 'х')]");""))
 
 
 
#10
05.08.2022 13:32:59
Ігор Гончаренко, Да круто сработало,  где нужно заменить, чтобы тут есть места где перед габаритами стоит 2 пробела и тогда он удаляет и всё норм, а если стоит 1 пробел то он не удаляет габариты. приложил файл. Но всё равно круто, вы гений
Изменено: Гыга Гого - 05.08.2022 13:34:21
 
 
 
#11
05.08.2022 13:41:20
№№ строк с проблемами?
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#12
05.08.2022 13:55:43
Ігор Гончаренко, 36,37,39 например
место 1   из 1; Тумба мобильная (корпус) 430x650x569; (детали, фурнитура); цвет: оникс   серыйместо 1 из 1; Тумба мобильная   (корпус) 430x650x569; (детали, фурнитура)Оникс серый
Изменено: Гыга Гого - 05.08.2022 13:57:36
 
 
 
#13
05.08.2022 14:02:39
Msi2102, Вот это тоже крутая штука, только почему то не везде сработала, возможно от количества символов как то зависит, вот попробуйте пожалуйста вот с этими строчками, можно где то сбоку отобразить строчку с формулой
 
 
 
#14
05.08.2022 14:11:51
пробелы не причем. кириллица х (ха) не равна латинской x (экс)
предлагаю выявить диверсанта и наказать как следует!
Код
Sub RunThis()
  Dim a, b, r&, re
  a = [a1].CurrentRegion:  ReDim b(1 To UBound(a), 1 To 2)
  b(1, 1) = "должно получиться": b(1, 2) = "Цвет"
  Set re = CreateObject("VBScript.RegExp")
  For r = 2 To UBound(a)
    re.Pattern = "\d+х\d+х\d+; "
    If re.test(a(r, 1)) Then a(r, 1) = re.Replace(a(r, 1), "")
    re.Pattern = "\d+x\d+x\d+; "
    If re.test(a(r, 1)) Then a(r, 1) = re.Replace(a(r, 1), "")
    re.Pattern = "\d+х\d+х\d+"
    If re.test(a(r, 1)) Then a(r, 1) = re.Replace(a(r, 1), "")
    re.Pattern = "\d+x\d+x\d+"
    If re.test(a(r, 1)) Then a(r, 1) = re.Replace(a(r, 1), "")
    re.Pattern = "; цвет:.+"
    If re.test(a(r, 1)) Then
      b(r, 2) = re.Execute(a(r, 1))(0)
      b(r, 2) = Right(b(r, 2), Len(b(r, 2)) - 8)
      If Len(b(r, 2)) Then Mid(b(r, 2), 1, 1) = UCase(Left(b(r, 2), 1))
      a(r, 1) = re.Replace(a(r, 1), "")
    End If
    b(r, 1) = a(r, 1)
  Next
  [d1].Resize(UBound(a), 2) = b
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#15
05.08.2022 14:39:29
Цитата
Гыга Гого написал:
почему то не везде сработала,
Потому что у Вас где-то "х", а где-то "икс",
а ещё есть например такое: место 1 из 1; Шкаф (бок., з.ст.) 1600x550x1520, левый  1600х550х1520; (Бок панели, задняя стенка); цвет: гикори натуральный Если с первым ещё решаемо так:
Код
=ПОДСТАВИТЬ(СЖПРОБЕЛЫ(A2);ФИЛЬТР.XML("<t><s>"&ПОДСТАВИТЬ(СЖПРОБЕЛЫ(A2);" ";"</s><s>")&"</s></t>";"//s[translate(.,'1234567890','')!=.][translate(.,'хx','')!=.][not(contains(., ')'))][position()=1]");"")

, то со вторым будет удалять только первое значение иначе нужно думать
Изменено: Msi2102 - 05.08.2022 16:51:29
 
 
 
#16
05.08.2022 15:37:14
Если так, то удалит все размеры
Код
Sub Макрос1()
Set re1 = CreateObject("VBScript.RegExp")
Set re2 = CreateObject("VBScript.RegExp")
re1.Pattern = "\d+(x|х)\d+(x|х)\d+(,|;)s*": re1.Global = True
re2.Pattern = ";?\s+цвет.+": re1.Global = True
a = [a1].CurrentRegion:  ReDim b(1 To UBound(a), 1 To 2)
For r = 2 To UBound(a)
    For i = 0 To re1.Execute(a(r, 1)).Count - 1
        b(r, 1) = WorksheetFunction.Trim(re1.Replace(a(r, 1), ""))
    Next
    For i = 0 To re2.Execute(b(r, 1)).Count - 1
        b(r, 2) = Trim(Split(b(r, 1), "цвет:")(1))
        b(r, 1) = WorksheetFunction.Trim(re2.Replace(b(r, 1), ""))
    Next
Next
    b(1, 1) = "НОВОЕ НАИМЕНОВАНИЕ"
    b(1, 2) = "ЦВЕТ"
    [d1].Resize(UBound(a), 2) = b
End Sub
Изменено: Msi2102 - 05.08.2022 15:44:18
 
 
 
#17
05.08.2022 16:23:40
Msi2102, а как сделать чтоб он удалял не только в такой ячейке а просто любые размеры состоящие из ...х...х.... ШВГ, потому что если будет такое то он уже не работает
Corner Комплект деталей стола руководителя прямого COR.PSR-18 1/3 Гикори песочный/Ваниль 1800*900*750
Изменено: Гыга Гого - 05.08.2022 16:24:03
 
 
 
#18
05.08.2022 16:33:02
Так:
Код
Sub Макрос1()
Set re1 = CreateObject("VBScript.RegExp")
Set re2 = CreateObject("VBScript.RegExp")
re1.Pattern = "\d+(x|х|\*)\d+(x|х|\*)\d+(,|;)*s*": re1.Global = True
re2.Pattern = ";?\s+цвет.+": re1.Global = True
a = [a1].CurrentRegion:  ReDim b(1 To UBound(a), 1 To 2)
For r = 2 To UBound(a)
    For i = 0 To re1.Execute(a(r, 1)).Count - 1
        b(r, 1) = WorksheetFunction.Trim(re1.Replace(a(r, 1), ""))
    Next
    For i = 0 To re2.Execute(b(r, 1)).Count - 1
        b(r, 2) = Trim(Split(b(r, 1), "цвет:")(1))
        b(r, 1) = WorksheetFunction.Trim(re2.Replace(b(r, 1), ""))
    Next
Next
    b(1, 1) = "НОВОЕ НАИМЕНОВАНИЕ"
    b(1, 2) = "ЦВЕТ"
    [d1].Resize(UBound(a), 2) = b
End Sub

PS: только цвет уже не определит, не от чего оттолкнуться
Изменено: Msi2102 - 05.08.2022 16:35:19
 
 
 
#19
05.08.2022 16:40:10
Msi2102, Да про цвет я понимаю, было бы так же цвет: тогда можно было, а в этом годе можно что то убрать, чтоб про столбец цвета вообще не было ничего, и если можно через кнопку как то, чтоб в 1 столбце все данные, на кнопку(допустим а а1 находится) нажать и в столбце 2 все эти данные без габаритов?
 
 
 
#20
05.08.2022 17:01:24
Вы уже определитесь, что хотите. Вот Вам 4 макроса, один вставляет без габаритов и цвета, цвет в отдельную ячейку, второй тоже только без отдельного столбца цвета, третий без габаритов с цветом, четвертый только цвет. Выбирайте, то, что нужно
 
 
 
Страницы: 1
Наверх