Добрый вечер! Посмотрите, пожалуйста, возможно ли макросом сделать такие махинации. Ячейка Ед.изм содержит значение типа 100 (может быть 1, 10 или ничего) м2 окрашиваемой поверхности.( может быть и м3 и т и шт и кг) Ячейка Кол-во содержит объем - 2,76. Возможно ли убрать из ячейки Ед.изм все, что после м2. Умножить ячейку Кол-во на цифру перед м2 (100), чтобы получилось 276 и удалить эту цифру (100). Чтобы получилось м2 276. Более наглядно в файле.
Добрый вечер! Посмотрите, пожалуйста, возможно ли макросом сделать такие махинации. Ячейка Ед.изм содержит значение типа 100 (может быть 1, 10 или ничего) м2 окрашиваемой поверхности.( может быть и м3 и т и шт и кг) Ячейка Кол-во содержит объем - 2,76. Возможно ли убрать из ячейки Ед.изм все, что после м2. Умножить ячейку Кол-во на цифру перед м2 (100), чтобы получилось 276 и удалить эту цифру (100). Чтобы получилось м2 276. Более наглядно в файле.CHEVRYACHOK
Какой-то бред сайт отображает. Попробую иначе. [vba]
Код
Sub www() Dim c As Range Range("D1:D14").Replace "м2*", "м2", xlPart For Each c In Range("D1:D14") If InStr(1, c, "1000") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 1000 ElseIf InStr(1, c, "100") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 100 End If Next Range("D1:D14").Replace "1", "", xlPart Range("D1:D14").Replace "0", "", xlPart Range("D1:D14") = Application.Trim(Range("D1:D14")) End Sub
[/vba]
Какой-то бред сайт отображает. Попробую иначе. [vba]
Код
Sub www() Dim c As Range Range("D1:D14").Replace "м2*", "м2", xlPart For Each c In Range("D1:D14") If InStr(1, c, "1000") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 1000 ElseIf InStr(1, c, "100") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 100 End If Next Range("D1:D14").Replace "1", "", xlPart Range("D1:D14").Replace "0", "", xlPart Range("D1:D14") = Application.Trim(Range("D1:D14")) End Sub
buchlotnik, У меня данных по 500 строк и таких файлов очень много, поэтому хотелось макросом.
KuklP, возможно, я просто плохо объяснил. Я извиняюсь. Не могли бы вы посмотреть файлик, там несколько строк не обрабатывает с вашим макросом
buchlotnik, У меня данных по 500 строк и таких файлов очень много, поэтому хотелось макросом.
KuklP, возможно, я просто плохо объяснил. Я извиняюсь. Не могли бы вы посмотреть файлик, там несколько строк не обрабатывает с вашим макросомCHEVRYACHOK
Sub www() Dim c As Range For Each c In Range("D1:D14") If InStr(1, c, "1000") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 1000 ElseIf InStr(1, c, "100") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 100 End If c.Value = c.Offset(, 5) Next End Sub
[/vba]
[vba]
Код
Sub www() Dim c As Range For Each c In Range("D1:D14") If InStr(1, c, "1000") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 1000 ElseIf InStr(1, c, "100") > 0 Then c.Offset(, 1) = c.Offset(, 1) * 100 End If c.Value = c.Offset(, 5) Next End Sub
Sub dd() Dim arr As Variant, arr1 As Variant, i&, s$ With [A1].CurrentRegion With Intersect(.Columns("D").Offset(3), .EntireRow) arr = .Value: arr1 = .Offset(, 1).Value With CreateObject("vbscript.regexp") .Pattern = "([0-99]+)?(\s?\S+).*" For i = 1 To UBound(arr) s = "trim(""$2 ""& " & arr1(i, 1) & "*text(0$1,""0;;1""))" arr(i, 1) = Evaluate(.Replace(arr(i, 1), s)) Next End With Application.ScreenUpdating = False: Application.DisplayAlerts = False .Value = arr: .TextToColumns .Cells(1), 1, , , , , , 1 Application.DisplayAlerts = True: Application.ScreenUpdating = True End With End With End Sub
[/vba]
до кучи [vba]
Код
Sub dd() Dim arr As Variant, arr1 As Variant, i&, s$ With [A1].CurrentRegion With Intersect(.Columns("D").Offset(3), .EntireRow) arr = .Value: arr1 = .Offset(, 1).Value With CreateObject("vbscript.regexp") .Pattern = "([0-99]+)?(\s?\S+).*" For i = 1 To UBound(arr) s = "trim(""$2 ""& " & arr1(i, 1) & "*text(0$1,""0;;1""))" arr(i, 1) = Evaluate(.Replace(arr(i, 1), s)) Next End With Application.ScreenUpdating = False: Application.DisplayAlerts = False .Value = arr: .TextToColumns .Cells(1), 1, , , , , , 1 Application.DisplayAlerts = True: Application.ScreenUpdating = True End With End With End Sub
KuklP, другим плюсанул в рейтинг Хотя будет не лишним и здесь - Всем огромное спасибо! Благодарен Вам, что есть такие люди, которые могут помочь другим. Я стараюсь с этим всем разобраться, так что, возможно, и я когда-нибудь смогу кому-нибудь помочь!
KuklP, другим плюсанул в рейтинг Хотя будет не лишним и здесь - Всем огромное спасибо! Благодарен Вам, что есть такие люди, которые могут помочь другим. Я стараюсь с этим всем разобраться, так что, возможно, и я когда-нибудь смогу кому-нибудь помочь! CHEVRYACHOK
KuklP, доброе утро и хорошего дня! Вчера разбирался с макросом и понял, что если удалить пример выделенный красным, то макрос не срабатывает, как нужно. Посмотрите, пожалуйста, можно ли это как-нибудь исправить.
KuklP, доброе утро и хорошего дня! Вчера разбирался с макросом и понял, что если удалить пример выделенный красным, то макрос не срабатывает, как нужно. Посмотрите, пожалуйста, можно ли это как-нибудь исправить.CHEVRYACHOK
Sub ertert() Dim r As Range, m& With CreateObject("vbscript.regexp") .Pattern = "(м\d?|шт.?|т|ед)" For Each r In Range("D4", Cells(Rows.Count, 4).End(xlUp)) m = Val(r.Value) If m > 1 Then r(1, 2) = r(1, 2) * m r = .Execute(r.Value)(0) Next End With End Sub
[/vba] Код желательно положить в стандартный модуль (не модуль листа)
CHEVRYACHOK, привет попробуйте так: [vba]
Код
Sub ertert() Dim r As Range, m& With CreateObject("vbscript.regexp") .Pattern = "(м\d?|шт.?|т|ед)" For Each r In Range("D4", Cells(Rows.Count, 4).End(xlUp)) m = Val(r.Value) If m > 1 Then r(1, 2) = r(1, 2) * m r = .Execute(r.Value)(0) Next End With End Sub
[/vba] Код желательно положить в стандартный модуль (не модуль листа)nilem
Sub ertert() Dim r As Range, m& With CreateObject("vbscript.regexp") .Pattern = "(м\d?|шт.?|т|кг)" For Each r In Range("D5", Cells(Rows.Count, 4).End(xlUp)) If Len(r.Value) Then If .test(r.Value) Then m = Val(r.Value) If m > 1 Then r(1, 2) = r(1, 2) * m r = .Execute(r.Value)(0) Else MsgBox "не определил " & r.Value, 48 End If End If Next End With End Sub
[/vba]
давайте еще парочку условий добавим: [vba]
Код
Sub ertert() Dim r As Range, m& With CreateObject("vbscript.regexp") .Pattern = "(м\d?|шт.?|т|кг)" For Each r In Range("D5", Cells(Rows.Count, 4).End(xlUp)) If Len(r.Value) Then If .test(r.Value) Then m = Val(r.Value) If m > 1 Then r(1, 2) = r(1, 2) * m r = .Execute(r.Value)(0) Else MsgBox "не определил " & r.Value, 48 End If End If Next End With End Sub