Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Удаление содержимого яч и умножение на число из содержимого - Мир MS Excel

Старая форма входа
  • Страница 1 из 2
  • 1
  • 2
  • »
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Удаление содержимого яч и умножение на число из содержимого (Макросы/Sub)
Удаление содержимого яч и умножение на число из содержимого
CHEVRYACHOK Дата: Четверг, 27.10.2016, 16:28 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Добрый вечер!
Посмотрите, пожалуйста, возможно ли макросом сделать такие махинации.
Ячейка Ед.изм содержит значение типа 100 (может быть 1, 10 или ничего) м2 окрашиваемой поверхности.( может быть и м3 и т и шт и кг)
Ячейка Кол-во содержит объем - 2,76.
Возможно ли убрать из ячейки Ед.изм все, что после м2.
Умножить ячейку Кол-во на цифру перед м2 (100), чтобы получилось 276 и удалить эту цифру (100).
Чтобы получилось м2 276.
Более наглядно в файле.
К сообщению приложен файл: 4612494.xlsm (11.6 Kb)
 
Ответить
СообщениеДобрый вечер!
Посмотрите, пожалуйста, возможно ли макросом сделать такие махинации.
Ячейка Ед.изм содержит значение типа 100 (может быть 1, 10 или ничего) м2 окрашиваемой поверхности.( может быть и м3 и т и шт и кг)
Ячейка Кол-во содержит объем - 2,76.
Возможно ли убрать из ячейки Ед.изм все, что после м2.
Умножить ячейку Кол-во на цифру перед м2 (100), чтобы получилось 276 и удалить эту цифру (100).
Чтобы получилось м2 276.
Более наглядно в файле.

Автор - CHEVRYACHOK
Дата добавления - 27.10.2016 в 16:28
KuklP Дата: Четверг, 27.10.2016, 16:48 | Сообщение № 2
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
[vba]
Код
Sub www()
    Dim c As Range
    Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14").Replace "м2*", "м2", xlPart
    For Each c In Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14")
        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 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14").Replace "1", "", xlPart
    Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14").Replace "0", "", xlPart
    Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14") = Application.Trim(Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14"))
End Sub
[/vba]


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Четверг, 27.10.2016, 16:49
 
Ответить
Сообщение[vba]
Код
Sub www()
    Dim c As Range
    Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14").Replace "м2*", "м2", xlPart
    For Each c In Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14")
        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 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14").Replace "1", "", xlPart
    Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14").Replace "0", "", xlPart
    Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14") = Application.Trim(Range("D1 <img rel="usm" src="/sml2/biggrin.gif" border="0" align="absmiddle" alt=":D" /> 14"))
End Sub
[/vba]

Автор - KuklP
Дата добавления - 27.10.2016 в 16:48
KuklP Дата: Четверг, 27.10.2016, 16:50 | Сообщение № 3
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Какой-то бред сайт отображает. Попробую иначе.
[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]
К сообщению приложен файл: _4612494-1.xlsm (19.2 Kb)


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Четверг, 27.10.2016, 16:53
 
Ответить
СообщениеКакой-то бред сайт отображает. Попробую иначе.
[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]

Автор - KuklP
Дата добавления - 27.10.2016 в 16:50
buchlotnik Дата: Четверг, 27.10.2016, 16:51 | Сообщение № 4
Группа: Заблокированные
Ранг: Участник клуба
Сообщений: 3442
Репутация: 929 ±
Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG
А чем формулы не годятся?
К сообщению приложен файл: 3309115.xlsm (12.4 Kb)
 
Ответить
СообщениеА чем формулы не годятся?

Автор - buchlotnik
Дата добавления - 27.10.2016 в 16:51
buchlotnik Дата: Четверг, 27.10.2016, 16:51 | Сообщение № 5
Группа: Заблокированные
Ранг: Участник клуба
Сообщений: 3442
Репутация: 929 ±
Замечаний: 20% ±

2010, 2013, 2016 RUS / ENG
Цитата
Какой-то бред
KuklP, выключите смайлики - тут глюки на сайте


Сообщение отредактировал buchlotnik - Четверг, 27.10.2016, 16:52
 
Ответить
Сообщение
Цитата
Какой-то бред
KuklP, выключите смайлики - тут глюки на сайте

Автор - buchlotnik
Дата добавления - 27.10.2016 в 16:51
sboy Дата: Четверг, 27.10.2016, 16:55 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 2566
Репутация: 724 ±
Замечаний: 0% ±

Excel 2010
Добрый день.
Решил формулами
для обозначения ед.измерения
Код
=ЕСЛИОШИБКА(СЖПРОБЕЛЫ(ПСТР(D4;НАЙТИ(" ";D4);3));D4)

для количества
Код
=ЕСЛИОШИБКА(ПСТР(D4;1;НАЙТИ(" ";D4)-1)*E4;E4)
К сообщению приложен файл: 2500325.xlsm (12.0 Kb)


Яндекс: 410016850021169
 
Ответить
СообщениеДобрый день.
Решил формулами
для обозначения ед.измерения
Код
=ЕСЛИОШИБКА(СЖПРОБЕЛЫ(ПСТР(D4;НАЙТИ(" ";D4);3));D4)

для количества
Код
=ЕСЛИОШИБКА(ПСТР(D4;1;НАЙТИ(" ";D4)-1)*E4;E4)

Автор - sboy
Дата добавления - 27.10.2016 в 16:55
KuklP Дата: Четверг, 27.10.2016, 16:57 | Сообщение № 7
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
Возможно ли убрать из ячейки Ед.изм все, что после м2.
... и удалить эту цифру (100).
Чтобы получилось м2 276.
У меня плохо с языком?


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
Сообщение
Возможно ли убрать из ячейки Ед.изм все, что после м2.
... и удалить эту цифру (100).
Чтобы получилось м2 276.
У меня плохо с языком?

Автор - KuklP
Дата добавления - 27.10.2016 в 16:57
CHEVRYACHOK Дата: Четверг, 27.10.2016, 17:24 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
buchlotnik,
У меня данных по 500 строк и таких файлов очень много, поэтому хотелось макросом.

KuklP, возможно, я просто плохо объяснил. Я извиняюсь.
Не могли бы вы посмотреть файлик, там несколько строк не обрабатывает с вашим макросом
К сообщению приложен файл: _1.xlsm (16.8 Kb)
 
Ответить
Сообщениеbuchlotnik,
У меня данных по 500 строк и таких файлов очень много, поэтому хотелось макросом.

KuklP, возможно, я просто плохо объяснил. Я извиняюсь.
Не могли бы вы посмотреть файлик, там несколько строк не обрабатывает с вашим макросом

Автор - CHEVRYACHOK
Дата добавления - 27.10.2016 в 17:24
KuklP Дата: Четверг, 27.10.2016, 17:38 | Сообщение № 9
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
[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
[/vba]


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728


Сообщение отредактировал KuklP - Четверг, 27.10.2016, 18:29
 
Ответить
Сообщение[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
[/vba]

Автор - KuklP
Дата добавления - 27.10.2016 в 17:38
krosav4ig Дата: Четверг, 27.10.2016, 17:43 | Сообщение № 10
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
до кучи [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
[/vba]
К сообщению приложен файл: 8633877.xlsm (20.7 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Четверг, 27.10.2016, 17:48
 
Ответить
Сообщениедо кучи [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
[/vba]

Автор - krosav4ig
Дата добавления - 27.10.2016 в 17:43
CHEVRYACHOK Дата: Четверг, 27.10.2016, 18:24 | Сообщение № 11
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
KuklP, Все отлично! Спасибо!
 
Ответить
СообщениеKuklP, Все отлично! Спасибо!

Автор - CHEVRYACHOK
Дата добавления - 27.10.2016 в 18:24
KuklP Дата: Четверг, 27.10.2016, 18:26 | Сообщение № 12
Группа: Проверенные
Ранг: Старожил
Сообщений: 2369
Репутация: 486 ±
Замечаний: 0% ±

2003-2010
А другим участникам? Тоже старались для Вас.


Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728
 
Ответить
СообщениеА другим участникам? Тоже старались для Вас.

Автор - KuklP
Дата добавления - 27.10.2016 в 18:26
CHEVRYACHOK Дата: Четверг, 27.10.2016, 18:27 | Сообщение № 13
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
krosav4ig, у меня почему-то ругается на вот эту строку

arr(i, 1) = Evaluate(.Replace(arr(i, 1), s))
 
Ответить
Сообщениеkrosav4ig, у меня почему-то ругается на вот эту строку

arr(i, 1) = Evaluate(.Replace(arr(i, 1), s))

Автор - CHEVRYACHOK
Дата добавления - 27.10.2016 в 18:27
CHEVRYACHOK Дата: Четверг, 27.10.2016, 18:32 | Сообщение № 14
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
KuklP, другим плюсанул в рейтинг yes
Хотя будет не лишним и здесь - Всем огромное спасибо!
Благодарен Вам, что есть такие люди, которые могут помочь другим.
Я стараюсь с этим всем разобраться, так что, возможно, и я когда-нибудь
смогу кому-нибудь помочь! yes
 
Ответить
СообщениеKuklP, другим плюсанул в рейтинг yes
Хотя будет не лишним и здесь - Всем огромное спасибо!
Благодарен Вам, что есть такие люди, которые могут помочь другим.
Я стараюсь с этим всем разобраться, так что, возможно, и я когда-нибудь
смогу кому-нибудь помочь! yes

Автор - CHEVRYACHOK
Дата добавления - 27.10.2016 в 18:32
CHEVRYACHOK Дата: Пятница, 28.10.2016, 07:42 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
KuklP, доброе утро и хорошего дня!
Вчера разбирался с макросом и понял, что если удалить пример выделенный красным,
то макрос не срабатывает, как нужно.
Посмотрите, пожалуйста, можно ли это как-нибудь исправить.
К сообщению приложен файл: _2.xlsm (15.7 Kb)
 
Ответить
СообщениеKuklP, доброе утро и хорошего дня!
Вчера разбирался с макросом и понял, что если удалить пример выделенный красным,
то макрос не срабатывает, как нужно.
Посмотрите, пожалуйста, можно ли это как-нибудь исправить.

Автор - CHEVRYACHOK
Дата добавления - 28.10.2016 в 07:42
nilem Дата: Пятница, 28.10.2016, 11:05 | Сообщение № 16
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
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]
Код желательно положить в стандартный модуль (не модуль листа)


Яндекс.Деньги 4100159601573
 
Ответить
Сообщение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
Дата добавления - 28.10.2016 в 11:05
CHEVRYACHOK Дата: Пятница, 28.10.2016, 12:38 | Сообщение № 17
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
nilem, добрый день! На примере отрабатывает, а на файле чуть больше - ошибка.
Файл приложил.
К сообщению приложен файл: _3.xlsm (27.7 Kb)
 
Ответить
Сообщениеnilem, добрый день! На примере отрабатывает, а на файле чуть больше - ошибка.
Файл приложил.

Автор - CHEVRYACHOK
Дата добавления - 28.10.2016 в 12:38
nilem Дата: Пятница, 28.10.2016, 17:30 | Сообщение № 18
Группа: Авторы
Ранг: Старожил
Сообщений: 1613
Репутация: 563 ±
Замечаний: 0% ±

Excel 2013, 2016
давайте еще парочку условий добавим:
[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
[/vba]


Яндекс.Деньги 4100159601573
 
Ответить
Сообщениедавайте еще парочку условий добавим:
[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
[/vba]

Автор - nilem
Дата добавления - 28.10.2016 в 17:30
krosav4ig Дата: Пятница, 28.10.2016, 19:47 | Сообщение № 19
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
ругается на вот эту строку

arr(i, 1) = Evaluate(.Replace(arr(i, 1), s))

попробуйте вот так погонять
[vba]
Код
Sub dd()
10  On Error GoTo Er
    Dim arr As Variant, arr1 As Variant, i&, s$
20  With [A1].CurrentRegion
30      With Intersect(.Columns("D").Offset(5), .EntireRow)
40          arr = .Value: arr1 = .Offset(, 1).Formula
50          With CreateObject("vbscript.regexp")
60              .Pattern = "([0-9]+)?(\s?\S+).*"
70              For i = 1 To UBound(arr)
80                  If .test(arr(i, 1)) Then
90                      s = "=trim(""$2 ""& 0" & arr1(i, 1) & "*text(0$1,""0;;1""))"
100                     arr(i, 1) = Evaluate(.Replace(arr(i, 1), s))
110                 End If
120             Next
130         End With
140         Parent.ScreenUpdating = False: Parent.DisplayAlerts = False
150         .Formula = Parent.Substitute(arr, ".", Parent.DecimalSeparator)
160         .TextToColumns .Cells(1), 1, , , , , , 1
170         Parent.DisplayAlerts = True: Parent.ScreenUpdating = True
180     End With
190 End With
200 Exit Sub
Er:
210 Parent.DisplayAlerts = True: Parent.ScreenUpdating = True
220 With Parent.VBE.MainWindow.LinkedWindows
230     .Add Parent.VBE.Windows("Immediate")
240     .Add Parent.VBE.Windows("Locals")
250 End With
    'Application.VBE.Windows("Immediate").Visible = True
    'Application.VBE.Windows("Locals").Visible = True
260 Debug.Print "Ошибка " & Err.Number & " (" & Err.Description & ") на строке " & Erl
270 Stop
280 Err.Clear
290 Resume Next
End Sub
[/vba]
и посмотреть, что в окошках Locals и Immediate при ошибке
К сообщению приложен файл: 5764018.xlsm (35.5 Kb)


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Пятница, 28.10.2016, 19:50
 
Ответить
Сообщение
ругается на вот эту строку

arr(i, 1) = Evaluate(.Replace(arr(i, 1), s))

попробуйте вот так погонять
[vba]
Код
Sub dd()
10  On Error GoTo Er
    Dim arr As Variant, arr1 As Variant, i&, s$
20  With [A1].CurrentRegion
30      With Intersect(.Columns("D").Offset(5), .EntireRow)
40          arr = .Value: arr1 = .Offset(, 1).Formula
50          With CreateObject("vbscript.regexp")
60              .Pattern = "([0-9]+)?(\s?\S+).*"
70              For i = 1 To UBound(arr)
80                  If .test(arr(i, 1)) Then
90                      s = "=trim(""$2 ""& 0" & arr1(i, 1) & "*text(0$1,""0;;1""))"
100                     arr(i, 1) = Evaluate(.Replace(arr(i, 1), s))
110                 End If
120             Next
130         End With
140         Parent.ScreenUpdating = False: Parent.DisplayAlerts = False
150         .Formula = Parent.Substitute(arr, ".", Parent.DecimalSeparator)
160         .TextToColumns .Cells(1), 1, , , , , , 1
170         Parent.DisplayAlerts = True: Parent.ScreenUpdating = True
180     End With
190 End With
200 Exit Sub
Er:
210 Parent.DisplayAlerts = True: Parent.ScreenUpdating = True
220 With Parent.VBE.MainWindow.LinkedWindows
230     .Add Parent.VBE.Windows("Immediate")
240     .Add Parent.VBE.Windows("Locals")
250 End With
    'Application.VBE.Windows("Immediate").Visible = True
    'Application.VBE.Windows("Locals").Visible = True
260 Debug.Print "Ошибка " & Err.Number & " (" & Err.Description & ") на строке " & Erl
270 Stop
280 Err.Clear
290 Resume Next
End Sub
[/vba]
и посмотреть, что в окошках Locals и Immediate при ошибке

Автор - krosav4ig
Дата добавления - 28.10.2016 в 19:47
CHEVRYACHOK Дата: Суббота, 29.10.2016, 07:17 | Сообщение № 20
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 109
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
nilem, krosav4ig,
Огромное спасибо!
Все прекрасно работает. hands
 
Ответить
Сообщениеnilem, krosav4ig,
Огромное спасибо!
Все прекрасно работает. hands

Автор - CHEVRYACHOK
Дата добавления - 29.10.2016 в 07:17
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Удаление содержимого яч и умножение на число из содержимого (Макросы/Sub)
  • Страница 1 из 2
  • 1
  • 2
  • »
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!