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

Вход

Регистрация

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

 

= Мир MS Excel/Сокращение размера кода с похожими повторяющимися действиями - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сокращение размера кода с похожими повторяющимися действиями (Макросы/Sub)
Сокращение размера кода с похожими повторяющимися действиями
Lyova Дата: Вторник, 24.04.2018, 23:54 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 137
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте!
Пользуясь подсказками "состряпал" вот такой код. Служит он вместо встроенного функционала "Таблицы данных". Работает быстрее и более удобен для меня по другим причинам.
Но получился он довольно громоздким и я подозреваю, что его можно сократить, но моих знаний на это не хватает.

Можно ли его сократить?

Заранее спасибо.

[vba]
Код
Sub Raschet()
Dim i&, Inp1 As Range, Out As Range, Out1 As Range, Out2 As Range
Dim Out3 As Range, Out4 As Range, Out5 As Range
Set Inp1 = [Sens!C80]
Set Out = [Sens!B13]
Set Out1 = [Sens!L13]
Set Out2 = [Sens!V13]
Set Out3 = [Sens!B47]
Set Out4 = [Sens!L47]
Set Out5 = [Sens!V47]
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For a = 3 To 9
   Inp1 = Cells(13, a)
[Sens!C81] = [Sens!B14]
   Application.Calculate
   Cells(14, a) = Out
   Cells(14, a + 10) = Out1
   Cells(14, a + 20) = Out2
   Cells(48, a) = Out3
   Cells(48, a + 10) = Out4
   Cells(48, a + 20) = Out5
[Sens!C81] = [Sens!B15]
   Application.Calculate
   Cells(15, a) = Out
   Cells(15, a + 10) = Out1
   Cells(15, a + 20) = Out2
   Cells(49, a) = Out3
   Cells(49, a + 10) = Out4
   Cells(49, a + 20) = Out5
[Sens!C81] = [Sens!B16]
   Application.Calculate
   Cells(16, a) = Out
   Cells(16, a + 10) = Out1
   Cells(16, a + 20) = Out2
   Cells(50, a) = Out3
   Cells(50, a + 10) = Out4
   Cells(50, a + 20) = Out5
[Sens!C81] = [Sens!B17]
   Application.Calculate
   Cells(17, a) = Out
   Cells(17, a + 10) = Out1
   Cells(17, a + 20) = Out2
   Cells(51, a) = Out3
   Cells(51, a + 10) = Out4
   Cells(51, a + 20) = Out5
[Sens!C81] = [Sens!B18]
   Application.Calculate
   Cells(18, a) = Out
   Cells(18, a + 10) = Out1
   Cells(18, a + 20) = Out2
   Cells(52, a) = Out3
   Cells(52, a + 10) = Out4
   Cells(52, a + 20) = Out5
[Sens!C81] = [Sens!B19]
   Application.Calculate
   Cells(19, a) = Out
   Cells(19, a + 10) = Out1
   Cells(19, a + 20) = Out2
   Cells(53, a) = Out3
   Cells(53, a + 10) = Out4
   Cells(53, a + 20) = Out5
[Sens!C81] = [Sens!B20]
   Application.Calculate
   Cells(20, a) = Out
   Cells(20, a + 10) = Out1
   Cells(20, a + 20) = Out2
   Cells(54, a) = Out3
   Cells(54, a + 10) = Out4
   Cells(54, a + 20) = Out5
Next a
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]


Сообщение отредактировал Lyova - Вторник, 24.04.2018, 23:56
 
Ответить
СообщениеЗдравствуйте!
Пользуясь подсказками "состряпал" вот такой код. Служит он вместо встроенного функционала "Таблицы данных". Работает быстрее и более удобен для меня по другим причинам.
Но получился он довольно громоздким и я подозреваю, что его можно сократить, но моих знаний на это не хватает.

Можно ли его сократить?

Заранее спасибо.

[vba]
Код
Sub Raschet()
Dim i&, Inp1 As Range, Out As Range, Out1 As Range, Out2 As Range
Dim Out3 As Range, Out4 As Range, Out5 As Range
Set Inp1 = [Sens!C80]
Set Out = [Sens!B13]
Set Out1 = [Sens!L13]
Set Out2 = [Sens!V13]
Set Out3 = [Sens!B47]
Set Out4 = [Sens!L47]
Set Out5 = [Sens!V47]
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For a = 3 To 9
   Inp1 = Cells(13, a)
[Sens!C81] = [Sens!B14]
   Application.Calculate
   Cells(14, a) = Out
   Cells(14, a + 10) = Out1
   Cells(14, a + 20) = Out2
   Cells(48, a) = Out3
   Cells(48, a + 10) = Out4
   Cells(48, a + 20) = Out5
[Sens!C81] = [Sens!B15]
   Application.Calculate
   Cells(15, a) = Out
   Cells(15, a + 10) = Out1
   Cells(15, a + 20) = Out2
   Cells(49, a) = Out3
   Cells(49, a + 10) = Out4
   Cells(49, a + 20) = Out5
[Sens!C81] = [Sens!B16]
   Application.Calculate
   Cells(16, a) = Out
   Cells(16, a + 10) = Out1
   Cells(16, a + 20) = Out2
   Cells(50, a) = Out3
   Cells(50, a + 10) = Out4
   Cells(50, a + 20) = Out5
[Sens!C81] = [Sens!B17]
   Application.Calculate
   Cells(17, a) = Out
   Cells(17, a + 10) = Out1
   Cells(17, a + 20) = Out2
   Cells(51, a) = Out3
   Cells(51, a + 10) = Out4
   Cells(51, a + 20) = Out5
[Sens!C81] = [Sens!B18]
   Application.Calculate
   Cells(18, a) = Out
   Cells(18, a + 10) = Out1
   Cells(18, a + 20) = Out2
   Cells(52, a) = Out3
   Cells(52, a + 10) = Out4
   Cells(52, a + 20) = Out5
[Sens!C81] = [Sens!B19]
   Application.Calculate
   Cells(19, a) = Out
   Cells(19, a + 10) = Out1
   Cells(19, a + 20) = Out2
   Cells(53, a) = Out3
   Cells(53, a + 10) = Out4
   Cells(53, a + 20) = Out5
[Sens!C81] = [Sens!B20]
   Application.Calculate
   Cells(20, a) = Out
   Cells(20, a + 10) = Out1
   Cells(20, a + 20) = Out2
   Cells(54, a) = Out3
   Cells(54, a + 10) = Out4
   Cells(54, a + 20) = Out5
Next a
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

Автор - Lyova
Дата добавления - 24.04.2018 в 23:54
krosav4ig Дата: Среда, 25.04.2018, 03:47 | Сообщение № 2
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Здравствуйте.
Пробуйте так.
[vba]
Код
Sub Raschet()
    Dim i&, j&, r As Variant, v As Variant, a&
    Dim Inp1 As Range
    
    Set Inp1 = [Sens!C80]
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For a = 3 To 9
        Inp1 = Cells(13, a)
        i = 0
        For Each v In [Sens!B14:B20].Value
            [Sens!C81] = v
            Application.Calculate
            i = i + 1
            For Each r In Array(13, 47)
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460
 
Ответить
СообщениеЗдравствуйте.
Пробуйте так.
[vba]
Код
Sub Raschet()
    Dim i&, j&, r As Variant, v As Variant, a&
    Dim Inp1 As Range
    
    Set Inp1 = [Sens!C80]
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For a = 3 To 9
        Inp1 = Cells(13, a)
        i = 0
        For Each v In [Sens!B14:B20].Value
            [Sens!C81] = v
            Application.Calculate
            i = i + 1
            For Each r In Array(13, 47)
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 25.04.2018 в 03:47
Lyova Дата: Среда, 25.04.2018, 11:50 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 137
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
krosav4ig,
Здравствуйте!
Спасибо большое за помощь - все работает и даже чуть быстрее.

Но у меня еще одна проблема. Сегодня пришла еще одна "вводная". Мне необходимо добавить данные для анализа. Нужно добавить аналогичные по логике построения две группы таблиц, только в них используются другие комбинации переменных. По аналогии с вашим вариантом я написал для каждой из групп таблиц свой код. Каждый из них протестировал - работают правильно.
Но вот как объединить их в один я не знаю. Помучился, но так и не смог.

Не сочтите за наглость, подскажите, пожалуйста, как три кода объединить в один.

Обратите внимание, что есть ньюанс.
Перед выполнением Raschet 1 ячейка C80 (которая менялась в Raschet) обязательно должна стать =1 и не меняться больше. По аналогии: после выполнения Raschet 1 перед выполнением Raschet 2 ячейки C81 и C82 тоже должны быть равны 1 и не меняться

[vba]
Код
Sub Raschet1()
    Dim i&, j&, r As Variant, v As Variant, a&
    Dim Inp1 As Range
    
    Set Inp1 = [Sens!C82]
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For a = 3 To 9
        Inp1 = Cells(23, a)
        i = 0
        For Each v In [Sens!B23:B29].Value
            [Sens!C81] = v
            Application.Calculate
            i = i + 1
            For Each r In Array(23, 57)
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

[vba]
Код
Sub Raschet2()
    Dim i&, j&, r As Variant, v As Variant, a&
    Dim Inp1 As Range
    
    Set Inp1 = [Sens!C83]
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For a = 3 To 9
        Inp1 = Cells(33, a)
        i = 0
        For Each v In [Sens!B33:B39].Value
            [Sens!C84] = v
            Application.Calculate
            i = i + 1
            For Each r In Array(33, 67)
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]


Сообщение отредактировал Lyova - Среда, 25.04.2018, 11:51
 
Ответить
Сообщениеkrosav4ig,
Здравствуйте!
Спасибо большое за помощь - все работает и даже чуть быстрее.

Но у меня еще одна проблема. Сегодня пришла еще одна "вводная". Мне необходимо добавить данные для анализа. Нужно добавить аналогичные по логике построения две группы таблиц, только в них используются другие комбинации переменных. По аналогии с вашим вариантом я написал для каждой из групп таблиц свой код. Каждый из них протестировал - работают правильно.
Но вот как объединить их в один я не знаю. Помучился, но так и не смог.

Не сочтите за наглость, подскажите, пожалуйста, как три кода объединить в один.

Обратите внимание, что есть ньюанс.
Перед выполнением Raschet 1 ячейка C80 (которая менялась в Raschet) обязательно должна стать =1 и не меняться больше. По аналогии: после выполнения Raschet 1 перед выполнением Raschet 2 ячейки C81 и C82 тоже должны быть равны 1 и не меняться

[vba]
Код
Sub Raschet1()
    Dim i&, j&, r As Variant, v As Variant, a&
    Dim Inp1 As Range
    
    Set Inp1 = [Sens!C82]
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For a = 3 To 9
        Inp1 = Cells(23, a)
        i = 0
        For Each v In [Sens!B23:B29].Value
            [Sens!C81] = v
            Application.Calculate
            i = i + 1
            For Each r In Array(23, 57)
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

[vba]
Код
Sub Raschet2()
    Dim i&, j&, r As Variant, v As Variant, a&
    Dim Inp1 As Range
    
    Set Inp1 = [Sens!C83]
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    For a = 3 To 9
        Inp1 = Cells(33, a)
        i = 0
        For Each v In [Sens!B33:B39].Value
            [Sens!C84] = v
            Application.Calculate
            i = i + 1
            For Each r In Array(33, 67)
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
[/vba]

Автор - Lyova
Дата добавления - 25.04.2018 в 11:50
krosav4ig Дата: Среда, 25.04.2018, 16:23 | Сообщение № 4
Группа: Друзья
Ранг: Старожил
Сообщений: 2346
Репутация: 989 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Так надо?
[vba]
Код
Option Explicit
Sub Raschet()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Calc [Sens!C80], [Sens!C81], [Sens!B14:B20].Value, Array(13, 47)
    Calc [Sens!C81], [Sens!C82], [Sens!B23:B29].Value, Array(23, 57)
    Calc [Sens!C83], [Sens!C84], [Sens!B33:B39].Value, Array(33, 67)
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub Calc(ByRef r1 As Range, ByRef r2 As Range, arr1 As Variant, arr2 As Variant)
Dim a&, i&, j&, r As Variant, v As Variant
    For a = 3 To 9
        r1 = Cells(arr2(0), a)
        i = 0
        For Each v In arr1
            r2 = v
            Application.Calculate
            i = i + 1
            For Each r In arr2
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    r1 = 1
End Sub
[/vba]


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

Сообщение отредактировал krosav4ig - Среда, 25.04.2018, 16:26
 
Ответить
СообщениеТак надо?
[vba]
Код
Option Explicit
Sub Raschet()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Calc [Sens!C80], [Sens!C81], [Sens!B14:B20].Value, Array(13, 47)
    Calc [Sens!C81], [Sens!C82], [Sens!B23:B29].Value, Array(23, 57)
    Calc [Sens!C83], [Sens!C84], [Sens!B33:B39].Value, Array(33, 67)
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
Sub Calc(ByRef r1 As Range, ByRef r2 As Range, arr1 As Variant, arr2 As Variant)
Dim a&, i&, j&, r As Variant, v As Variant
    For a = 3 To 9
        r1 = Cells(arr2(0), a)
        i = 0
        For Each v In arr1
            r2 = v
            Application.Calculate
            i = i + 1
            For Each r In arr2
                For j = 0 To 20 Step 10
                    Cells(r + i, a + j) = [Sens!B1].Offset(r - 1, j)
    Next j, r, v, a
    r1 = 1
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 25.04.2018 в 16:23
Lyova Дата: Среда, 25.04.2018, 17:44 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 137
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
krosav4ig,

К сожалению, правильно считается только первая группа таблиц. В остальных данные перемешаны. Т.е. результат другой, чем если запускать один за другим "маленькие" макросы.
На всякий случай еще раз хотел уточнить: в ячейках C80, C81, C82, C83 и C84 изначально стоят "1". Все пять ячеек являются факторами, влияющими на конечный результат.Последовательно в них подставляются данные из 13,23 и 33 строк (они одинаковые) - диапазон от 70% до 130% с шагом 10%.
После того как выполниться "первый" код ( код заполняющий первую группу таблиц, в которых отражается результат, анализирующий влияние на конечный результат факторов, расположенных в клетках C80и С81) необходимо, чтобы значения в этих ячейках стали равны 1. Иначе это будет влиять на результат, получаемый при выполнении "второго" кода, который оценивает влияние факторов, расположенных в клетках С81 и С82. Соответственно, перед выполнением третьего кода ячейки С80, С81, С82 должны быть равны 1, потому что следующий код оценивает влияние факторов из ячеек С83 и С84.
Возможно я ошибаюсь, на мне кажется, что собака где-то здесь зарылась
 
Ответить
Сообщениеkrosav4ig,

К сожалению, правильно считается только первая группа таблиц. В остальных данные перемешаны. Т.е. результат другой, чем если запускать один за другим "маленькие" макросы.
На всякий случай еще раз хотел уточнить: в ячейках C80, C81, C82, C83 и C84 изначально стоят "1". Все пять ячеек являются факторами, влияющими на конечный результат.Последовательно в них подставляются данные из 13,23 и 33 строк (они одинаковые) - диапазон от 70% до 130% с шагом 10%.
После того как выполниться "первый" код ( код заполняющий первую группу таблиц, в которых отражается результат, анализирующий влияние на конечный результат факторов, расположенных в клетках C80и С81) необходимо, чтобы значения в этих ячейках стали равны 1. Иначе это будет влиять на результат, получаемый при выполнении "второго" кода, который оценивает влияние факторов, расположенных в клетках С81 и С82. Соответственно, перед выполнением третьего кода ячейки С80, С81, С82 должны быть равны 1, потому что следующий код оценивает влияние факторов из ячеек С83 и С84.
Возможно я ошибаюсь, на мне кажется, что собака где-то здесь зарылась

Автор - Lyova
Дата добавления - 25.04.2018 в 17:44
Lyova Дата: Среда, 25.04.2018, 18:14 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 137
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
krosav4ig,
На всякий случай сделал пример, как это будет выглядеть (влож.файл)
К сообщению приложен файл: _3.xls (67.0 Kb)
 
Ответить
Сообщениеkrosav4ig,
На всякий случай сделал пример, как это будет выглядеть (влож.файл)

Автор - Lyova
Дата добавления - 25.04.2018 в 18:14
Lyova Дата: Пятница, 27.04.2018, 00:52 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 137
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
krosav4ig, ?
 
Ответить
Сообщениеkrosav4ig, ?

Автор - Lyova
Дата добавления - 27.04.2018 в 00:52
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сокращение размера кода с похожими повторяющимися действиями (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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