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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос деления числа с одного столбца на число с другого - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Макрос деления числа с одного столбца на число с другого
grh1 Дата: Четверг, 06.06.2019, 15:08 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 233
Репутация: 0 ±
Замечаний: 40% ±

2019
Добрый день уважаемые знатоки!
Уважаемый Борода составил макрос, который выполняет:

- из таблицы, выбирает ДВА столбца (в примере выделено синим) и производит следующие действия как в примере ниже:

Пример:

БЫЛО ТАК

100м2---0,385
м----7,4
10м-----8,2

СТАЛО так:

м2---38,5
м-----7,4
м-----82

Т.е. макрос убирает все ЧИСЛОВЫЕ значения со столбца и одновременно умножает на убранное число то значение, которое в следующем столбце.

Хотел бы попросить уважаемого Бороду (или кого-либо еще), в прикрепленном примере, добавить действия по третьему столбу - разделить и убрать подчеркивание.

Спасибо.
К сообщению приложен файл: _--.xls (39.5 Kb)


Vadym Gorokh
 
Ответить
СообщениеДобрый день уважаемые знатоки!
Уважаемый Борода составил макрос, который выполняет:

- из таблицы, выбирает ДВА столбца (в примере выделено синим) и производит следующие действия как в примере ниже:

Пример:

БЫЛО ТАК

100м2---0,385
м----7,4
10м-----8,2

СТАЛО так:

м2---38,5
м-----7,4
м-----82

Т.е. макрос убирает все ЧИСЛОВЫЕ значения со столбца и одновременно умножает на убранное число то значение, которое в следующем столбце.

Хотел бы попросить уважаемого Бороду (или кого-либо еще), в прикрепленном примере, добавить действия по третьему столбу - разделить и убрать подчеркивание.

Спасибо.

Автор - grh1
Дата добавления - 06.06.2019 в 15:08
_Boroda_ Дата: Четверг, 06.06.2019, 16:08 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 16718
Репутация: 6505 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Так нужно?
[vba]
Код
Sub tt()
    c_ = 4
    r0_ = 5
    n_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 1
    If n_ < 1 Then Exit Sub
    ar = Cells(r0_, c_).Resize(n_, 3)
    On Error Resume Next
    For i = 1 To n_
        If IsNumeric(ar(i, 2)) And ar(i, 2) > 0 Then
            ar(i, 1) = Trim(ar(i, 1))
            If CByte(Left(ar(i, 1), 1)) Then
                For j = 1 To Len(ar(i, 1))
                    If Not IsNumeric(Left(ar(i, 1), j)) Then
                        ar(i, 3) = ar(i, 3) / Left(ar(i, 1), j - 1)
                        ar(i, 2) = ar(i, 2) * Left(ar(i, 1), j - 1)
                        ar(i, 1) = Mid(ar(i, 1), j)
                        Exit For
                    End If
                Next j
            End If
        End If
    Next i
    Cells(r0_, c_).Resize(n_, 3) = ar
    Cells(r0_, c_ + 2).Resize(n_).Font.Underline = xlUnderlineStyleNone
End Sub
[/vba]
К сообщению приложен файл: -5.xls (63.5 Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТак нужно?
[vba]
Код
Sub tt()
    c_ = 4
    r0_ = 5
    n_ = Cells(Rows.Count, c_).End(3).Row - r0_ + 1
    If n_ < 1 Then Exit Sub
    ar = Cells(r0_, c_).Resize(n_, 3)
    On Error Resume Next
    For i = 1 To n_
        If IsNumeric(ar(i, 2)) And ar(i, 2) > 0 Then
            ar(i, 1) = Trim(ar(i, 1))
            If CByte(Left(ar(i, 1), 1)) Then
                For j = 1 To Len(ar(i, 1))
                    If Not IsNumeric(Left(ar(i, 1), j)) Then
                        ar(i, 3) = ar(i, 3) / Left(ar(i, 1), j - 1)
                        ar(i, 2) = ar(i, 2) * Left(ar(i, 1), j - 1)
                        ar(i, 1) = Mid(ar(i, 1), j)
                        Exit For
                    End If
                Next j
            End If
        End If
    Next i
    Cells(r0_, c_).Resize(n_, 3) = ar
    Cells(r0_, c_ + 2).Resize(n_).Font.Underline = xlUnderlineStyleNone
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 06.06.2019 в 16:08
grh1 Дата: Четверг, 06.06.2019, 19:02 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 233
Репутация: 0 ±
Замечаний: 40% ±

2019
_Boroda_, большое спасибо и Вы как всегда на высоте.


Vadym Gorokh
 
Ответить
Сообщение_Boroda_, большое спасибо и Вы как всегда на высоте.

Автор - grh1
Дата добавления - 06.06.2019 в 19:02
  • Страница 1 из 1
  • 1
Поиск:

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