Здравствуйте! Пользуясь подсказками "состряпал" вот такой код. Служит он вместо встроенного функционала "Таблицы данных". Работает быстрее и более удобен для меня по другим причинам. Но получился он довольно громоздким и я подозреваю, что его можно сократить, но моих знаний на это не хватает.
Можно ли его сократить?
Заранее спасибо.
[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]
Здравствуйте! Пользуясь подсказками "состряпал" вот такой код. Служит он вместо встроенного функционала "Таблицы данных". Работает быстрее и более удобен для меня по другим причинам. Но получился он довольно громоздким и я подозреваю, что его можно сократить, но моих знаний на это не хватает.
Можно ли его сократить?
Заранее спасибо.
[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
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]
Здравствуйте. Пробуйте так. [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
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]
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
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]
Так надо? [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
К сожалению, правильно считается только первая группа таблиц. В остальных данные перемешаны. Т.е. результат другой, чем если запускать один за другим "маленькие" макросы. На всякий случай еще раз хотел уточнить: в ячейках 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