Нужна Ваша помощь с написанием макроса обработки прайса:
1. Во всех строках удалять все, что встретиться после первой запятой, удалять до тех пор, пока не встретится любое из условий, например текст: Dual, или 4G, или 32GB и тд...
Как удалить все после первой запятой нашел, а дальше тупик :)
[vba]
Код
Sub Macro1() Columns("A:A").Select Selection.Replace What:=",*", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End Sub
[/vba]
Исходник (файл с наименованием start) и пример (файл с наименованием finish) прилагаю. Надеюсь и рассчитываю на Вашу помощь в решении такой сложной задачи.
Всем доброго времени суток!
Нужна Ваша помощь с написанием макроса обработки прайса:
1. Во всех строках удалять все, что встретиться после первой запятой, удалять до тех пор, пока не встретится любое из условий, например текст: Dual, или 4G, или 32GB и тд...
Как удалить все после первой запятой нашел, а дальше тупик :)
[vba]
Код
Sub Macro1() Columns("A:A").Select Selection.Replace What:=",*", Replacement:="", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False End Sub
[/vba]
Исходник (файл с наименованием start) и пример (файл с наименованием finish) прилагаю. Надеюсь и рассчитываю на Вашу помощь в решении такой сложной задачи.force
Function tt(Text As String) As String With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|4G|32GB)" tt = .Replace(Text, " $1") End With End Function
[/vba]
Попробуйте так [vba]
Код
Function tt(Text As String) As String With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|4G|32GB)" tt = .Replace(Text, " $1") End With End Function
Sub tt() 'Обрабатывает все выделенные ячейки Dim Cell As Range With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|4G|32GB)" For Each Cell In Selection Cell.Value = .Replace(Cell.Value, " $1") Next End With End Sub
[/vba]
Можно процедурой (макросом) [vba]
Код
Sub tt() 'Обрабатывает все выделенные ячейки Dim Cell As Range With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|4G|32GB)" For Each Cell In Selection Cell.Value = .Replace(Cell.Value, " $1") Next End With End Sub
В исходник (файл с наименованием start) в модуль листа Телефоны [vba]
Код
Sub Telefon() Dim i As Long Dim j As Integer Dim iLastRow As Long Dim MyArr iLastRow = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To iLastRow If InStr(1, Cells(i, 1), ",") <> 0 Then MyArr = Split(Cells(i, 1), ",", 2) If InStr(1, MyArr(1), "Dual") = 0 And InStr(1, MyArr(1), "4G") = 0 _ And InStr(1, MyArr(1), "32GB") = 0 Then Cells(i, 3) = MyArr(0) & " " & MyArr(1) Else If InStr(1, MyArr(1), "Dual") <> 0 Then j = InStr(1, MyArr(1), "Dual") Cells(i, 3) = MyArr(0) & " " & Mid(MyArr(1), 1, j - 1) End If If InStr(1, MyArr(1), "4G") <> 0 Then j = InStr(1, MyArr(1), "4G") Cells(i, 3) = MyArr(0) & " " & Mid(MyArr(1), 1, j - 1) End If If InStr(1, MyArr(1), "32GB") <> 0 Then j = InStr(1, MyArr(1), "32GB") Cells(i, 3) = MyArr(0) & " " & Mid(MyArr(1), 1, j - 1) End If End If Else Cells(i, 3) = Cells(i, 1) End If Next End Sub
[/vba]
В исходник (файл с наименованием start) в модуль листа Телефоны [vba]
Код
Sub Telefon() Dim i As Long Dim j As Integer Dim iLastRow As Long Dim MyArr iLastRow = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To iLastRow If InStr(1, Cells(i, 1), ",") <> 0 Then MyArr = Split(Cells(i, 1), ",", 2) If InStr(1, MyArr(1), "Dual") = 0 And InStr(1, MyArr(1), "4G") = 0 _ And InStr(1, MyArr(1), "32GB") = 0 Then Cells(i, 3) = MyArr(0) & " " & MyArr(1) Else If InStr(1, MyArr(1), "Dual") <> 0 Then j = InStr(1, MyArr(1), "Dual") Cells(i, 3) = MyArr(0) & " " & Mid(MyArr(1), 1, j - 1) End If If InStr(1, MyArr(1), "4G") <> 0 Then j = InStr(1, MyArr(1), "4G") Cells(i, 3) = MyArr(0) & " " & Mid(MyArr(1), 1, j - 1) End If If InStr(1, MyArr(1), "32GB") <> 0 Then j = InStr(1, MyArr(1), "32GB") Cells(i, 3) = MyArr(0) & " " & Mid(MyArr(1), 1, j - 1) End If End If Else Cells(i, 3) = Cells(i, 1) End If Next End Sub
Спасибо за помощь, но Ваш вариант, к сожалению, не работает.
Asus Zenfone 2 Laser ZE500 KL 16GB Gold,Red,white4G, 2GB RAM, Dual SIM - было так, Asus Zenfone 2 Laser ZE500 KL 16GB Gold Red,white - стало так
Ваш вариант создает в другом столбце обработанные данные, обрабатывает не совсем по условию. Нужно чтобы получалось так => Asus Zenfone 2 Laser ZE500 KL 16GB Gold 4G, 2GB RAM, Dual SIM
Может Ваш вариант можно немного доработать, что бы он не удалял сами слова с условиями, а только удалял все после первой запятой, пока не встретит любое слово из массива условий?
Kuzmich,
Спасибо за помощь, но Ваш вариант, к сожалению, не работает.
Asus Zenfone 2 Laser ZE500 KL 16GB Gold,Red,white4G, 2GB RAM, Dual SIM - было так, Asus Zenfone 2 Laser ZE500 KL 16GB Gold Red,white - стало так
Ваш вариант создает в другом столбце обработанные данные, обрабатывает не совсем по условию. Нужно чтобы получалось так => Asus Zenfone 2 Laser ZE500 KL 16GB Gold 4G, 2GB RAM, Dual SIM
Может Ваш вариант можно немного доработать, что бы он не удалял сами слова с условиями, а только удалял все после первой запятой, пока не встретит любое слово из массива условий?force
Sub tt() 'Обрабатывает все выделенные ячейки Dim Cell As Range With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|4G|32GB)" On Error Resume Next For Each Cell In Selection If .Test(Cell.Value) Then Cell.Value = .Replace(Cell.Value, " $1") Else Cell.Value = Left(Cell.Value, InStr(Cell.Value, ",") - 1) End If Next End With End Sub
[/vba]
Чуть поправил макрос МВТ, [vba]
Код
Sub tt() 'Обрабатывает все выделенные ячейки Dim Cell As Range With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|4G|32GB)" On Error Resume Next For Each Cell In Selection If .Test(Cell.Value) Then Cell.Value = .Replace(Cell.Value, " $1") Else Cell.Value = Left(Cell.Value, InStr(Cell.Value, ",") - 1) End If Next End With End Sub
Я немного допилил Ваш вариант, посмотрите плиз, я добавил выделение столбцов до последнего заполненного:
[vba]
Код
Sub tt() 'Обрабатывает все выделенные ячейки Dim Cell As Range Dim lLastRow As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row Range("A1:A" & lLastRow).Select With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|Single|4G|3G|32GB|16GB|2GB|8GB|PCT|EAC|8G|ЕВРОПА)" On Error Resume Next For Each Cell In Selection If .Test(Cell.Value) Then Cell.Value = .Replace(Cell.Value, " $1") Else Cell.Value = Left(Cell.Value, InStr(Cell.Value, ",") - 1) End If Next End With End Sub
[/vba]
RAN,
Спасибо за помощь, Ваш вариант отлично работает!
Я немного допилил Ваш вариант, посмотрите плиз, я добавил выделение столбцов до последнего заполненного:
[vba]
Код
Sub tt() 'Обрабатывает все выделенные ячейки Dim Cell As Range Dim lLastRow As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row Range("A1:A" & lLastRow).Select With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|Single|4G|3G|32GB|16GB|2GB|8GB|PCT|EAC|8G|ЕВРОПА)" On Error Resume Next For Each Cell In Selection If .Test(Cell.Value) Then Cell.Value = .Replace(Cell.Value, " $1") Else Cell.Value = Left(Cell.Value, InStr(Cell.Value, ",") - 1) End If Next End With End Sub
Спасибо Вам за помощь! Буду рад, если подскажете как все это дело применить ко всем листам в книге!!!
Пытался сделать так: [vba]
Код
Sheets(Array(1, 2, 3)).Select
[/vba] Но так не работает, только если по отдельности прописать код к каждому листу...
[vba]
Код
Sub qqq() Sheets(1).Select For i = 2 To Range("A" & Rows.Count).End(xlUp).Row t = Cells(i, 1).Value ' значение из вашего текстового поля y = "" Z = "" If t Like "*,*" = True Then x = Split(t, ",") ' массив {"до разделителя", "после разделителя"} y = x(0) Z = Mid(t, Len(y) + 2) Select Case t <> "" Case Z Like "* 2GB*" x = Split(Z, "2GB") y = y & ", 2GB" & x(1) End Select Else y = t End If Cells(i, 1) = y Next Sheets(2).Select For i = 2 To Range("A" & Rows.Count).End(xlUp).Row t = Cells(i, 1).Value ' значение из вашего текстового поля y = "" Z = "" If t Like "*,*" = True Then x = Split(t, ",") ' массив {"до разделителя", "после разделителя"} y = x(0) Z = Mid(t, Len(y) + 2) Select Case t <> "" Case Z Like "* 2GB*" x = Split(Z, "2GB") y = y & ", 2GB" & x(1) End Select Else y = t End If Cells(i, 1) = y Next Sheets(3).Select For i = 2 To Range("A" & Rows.Count).End(xlUp).Row t = Cells(i, 1).Value ' значение из вашего текстового поля y = "" Z = "" If t Like "*,*" = True Then x = Split(t, ",") ' массив {"до разделителя", "после разделителя"} y = x(0) Z = Mid(t, Len(y) + 2) Select Case t <> "" Case Z Like "* 2GB*" x = Split(Z, "2GB") y = y & ", 2GB" & x(1) End Select Else y = t End If Cells(i, 1) = y Next End Sub
[/vba]
Такая "схема" работает, но может можно все сделать более красиво?
Kuzmich, и Wasilic,
Спасибо Вам за помощь! Буду рад, если подскажете как все это дело применить ко всем листам в книге!!!
Пытался сделать так: [vba]
Код
Sheets(Array(1, 2, 3)).Select
[/vba] Но так не работает, только если по отдельности прописать код к каждому листу...
[vba]
Код
Sub qqq() Sheets(1).Select For i = 2 To Range("A" & Rows.Count).End(xlUp).Row t = Cells(i, 1).Value ' значение из вашего текстового поля y = "" Z = "" If t Like "*,*" = True Then x = Split(t, ",") ' массив {"до разделителя", "после разделителя"} y = x(0) Z = Mid(t, Len(y) + 2) Select Case t <> "" Case Z Like "* 2GB*" x = Split(Z, "2GB") y = y & ", 2GB" & x(1) End Select Else y = t End If Cells(i, 1) = y Next Sheets(2).Select For i = 2 To Range("A" & Rows.Count).End(xlUp).Row t = Cells(i, 1).Value ' значение из вашего текстового поля y = "" Z = "" If t Like "*,*" = True Then x = Split(t, ",") ' массив {"до разделителя", "после разделителя"} y = x(0) Z = Mid(t, Len(y) + 2) Select Case t <> "" Case Z Like "* 2GB*" x = Split(Z, "2GB") y = y & ", 2GB" & x(1) End Select Else y = t End If Cells(i, 1) = y Next Sheets(3).Select For i = 2 To Range("A" & Rows.Count).End(xlUp).Row t = Cells(i, 1).Value ' значение из вашего текстового поля y = "" Z = "" If t Like "*,*" = True Then x = Split(t, ",") ' массив {"до разделителя", "после разделителя"} y = x(0) Z = Mid(t, Len(y) + 2) Select Case t <> "" Case Z Like "* 2GB*" x = Split(Z, "2GB") y = y & ", 2GB" & x(1) End Select Else y = t End If Cells(i, 1) = y Next End Sub
[/vba]
Такая "схема" работает, но может можно все сделать более красиво?force
Сообщение отредактировал force - Пятница, 19.02.2016, 21:42
Sub ttt() Dim Cell As Range, sh As Worksheet With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|Single|4G|3G|32GB|16GB|2GB|8GB|PCT|EAC|8G|ЕВРОПА)" On Error Resume Next For Each sh In Worksheets For Each Cell In sh.Range(sh.Cells(1, 1), sh.Cells(sh.Rows.Count, 1).End(xlUp)) If .Test(Cell.Value) Then Cell.Value = .Replace(Cell.Value, " $1") Else Cell.Value = Left(Cell.Value, InStr(Cell.Value, ",") - 1) End If Next Next End With End Sub
[/vba]
[vba]
Код
Sub ttt() Dim Cell As Range, sh As Worksheet With CreateObject("VBScript.RegExp") .Pattern = ",.+?(Dual|Single|4G|3G|32GB|16GB|2GB|8GB|PCT|EAC|8G|ЕВРОПА)" On Error Resume Next For Each sh In Worksheets For Each Cell In sh.Range(sh.Cells(1, 1), sh.Cells(sh.Rows.Count, 1).End(xlUp)) If .Test(Cell.Value) Then Cell.Value = .Replace(Cell.Value, " $1") Else Cell.Value = Left(Cell.Value, InStr(Cell.Value, ",") - 1) End If Next Next End With End Sub