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

Вход

Регистрация

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

 

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

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

Excel 2010
Добрый вечер!
Посмотрите, пожалуйста, возможно ли макросом сделать такие махинации.
Ячейка Ед.изм содержит значение типа 100 (может быть 1, 10 или ничего) м2 окрашиваемой поверхности.( может быть и м3 и т и шт и кг)
Ячейка Кол-во содержит объем - 2,76.
Возможно ли убрать из ячейки Ед.изм все, что после м2.
Умножить ячейку Кол-во на цифру перед м2 (100), чтобы получилось 276 и удалить эту цифру (100).
Чтобы получилось м2 276.
Более наглядно в файле.
К сообщению приложен файл: 4612494.xlsm(12Kb)
 
Ответить
СообщениеДобрый вечер!
Посмотрите, пожалуйста, возможно ли макросом сделать такие махинации.
Ячейка Ед.изм содержит значение типа 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
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

[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им! kuklp@mail.ru
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
Группа: Проверенные
Ранг: Старожил
Сообщений: 2006
Репутация: 436 ±
Замечаний: 20% ±

Какой-то бред сайт отображает. Попробую иначе.
[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(19Kb)


Ну, с НДС и мы чего-то стoим! kuklp@mail.ru
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
Группа: Друзья
Ранг: Старожил
Сообщений: 2049
Репутация: 613 ±
Замечаний: 0% ±

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


платная помощь:
ЯД: 410012595572239; WM: 311017577133
buchlotnik@mail.ru
 
Ответить
СообщениеА чем формулы не годятся?

Автор - buchlotnik
Дата добавления - 27.10.2016 в 16:51
buchlotnik Дата: Четверг, 27.10.2016, 16:51 | Сообщение № 5
Группа: Друзья
Ранг: Старожил
Сообщений: 2049
Репутация: 613 ±
Замечаний: 0% ±

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


платная помощь:
ЯД: 410012595572239; WM: 311017577133
buchlotnik@mail.ru


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

Автор - buchlotnik
Дата добавления - 27.10.2016 в 16:51
sboy Дата: Четверг, 27.10.2016, 16:55 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 198
Репутация: 49 ±
Замечаний: 0% ±

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

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

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

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

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


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

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

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

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

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

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

[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им! kuklp@mail.ru
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
Группа: Друзья
Ранг: Старожил
Сообщений: 1353
Репутация: 547 ±
Замечаний: 0% ±

Excel 2007, 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(21Kb)


(_)Õvõ(_)

Сообщение отредактировал 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
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

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

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

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


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

Автор - KuklP
Дата добавления - 27.10.2016 в 18:26
CHEVRYACHOK Дата: Четверг, 27.10.2016, 18:27 | Сообщение № 13
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 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
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

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

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

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

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

Excel 2013
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
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

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

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

Excel 2013
давайте еще парочку условий добавим:
[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
Группа: Друзья
Ранг: Старожил
Сообщений: 1353
Репутация: 547 ±
Замечаний: 0% ±

Excel 2007, 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(35Kb)


(_)Õvõ(_)

Сообщение отредактировал 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
Группа: Пользователи
Ранг: Участник
Сообщений: 91
Репутация: 0 ±
Замечаний: 0% ±

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

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

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