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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос переноса данных с промежуточным вычислением - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос переноса данных с промежуточным вычислением (Макросы/Sub)
Макрос переноса данных с промежуточным вычислением
Serj99 Дата: Вторник, 29.09.2015, 15:38 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Доброго дня всем!
Помогите написать код макроса для следующей задачи.
Есть два документа формата Excel – файлы «pds.xslx» и «forecast.xlsx».
В файле «pds.xslx» есть один лист (закладка), содержащая неизменную таблицу с числовыми значениями. Имя листа каждый день меняет свое название. Необходимо взять данные из определенных ячеек данного листа и произвести вычисление по формуле. Затем результат вычисления нужно перенести в определенную ячейку файла «forecast.xslx» на лист с именем «Прогноз».

Пример 1:
Вычислить в файле «pds.xslx» результат формулы (K25+I25*AG3+Q25+O25*AG3)*0,001 и перенести его в ячейку D8 файла «forecast.xlsx». Ячейка AG3 в файле «pds.xslx» должна вычисляться по формуле =ДЕНЬ(КОНМЕСЯЦА(СЕГОДНЯ();0))-P1 (ячейка Р1 имеет числовое значение дня текущего месяца).

Таким образом необходимо вычислить и перенести данные 46 раз. Формула для каждой из 46-ти ячеек файла «forecast.xlsx» может немного видоизменяться, но в целом будет однотипной.

Пример 2:
Результат формулы =(M25+I25*AG3+S25+O25*AG3)*0,001 из файла «pds.xslx» перенести в ячейку R8 файла «forecast.xlsx».
Результат формулы =(K57+I57*$AG$3)*0,001 из файла «pds.xslx» перенести в ячейку D9 файла «forecast.xlsx».
Результат формулы =(M57+I57*AG3)*0,001 из файла «pds.xslx» перенести в ячейку R9 файла «forecast.xlsx».
И так далее.

Макрос будет встроен в файл «forecast.xlsx» и данная операция будет выполнятся 1 раз в месяц.
 
Ответить
СообщениеДоброго дня всем!
Помогите написать код макроса для следующей задачи.
Есть два документа формата Excel – файлы «pds.xslx» и «forecast.xlsx».
В файле «pds.xslx» есть один лист (закладка), содержащая неизменную таблицу с числовыми значениями. Имя листа каждый день меняет свое название. Необходимо взять данные из определенных ячеек данного листа и произвести вычисление по формуле. Затем результат вычисления нужно перенести в определенную ячейку файла «forecast.xslx» на лист с именем «Прогноз».

Пример 1:
Вычислить в файле «pds.xslx» результат формулы (K25+I25*AG3+Q25+O25*AG3)*0,001 и перенести его в ячейку D8 файла «forecast.xlsx». Ячейка AG3 в файле «pds.xslx» должна вычисляться по формуле =ДЕНЬ(КОНМЕСЯЦА(СЕГОДНЯ();0))-P1 (ячейка Р1 имеет числовое значение дня текущего месяца).

Таким образом необходимо вычислить и перенести данные 46 раз. Формула для каждой из 46-ти ячеек файла «forecast.xlsx» может немного видоизменяться, но в целом будет однотипной.

Пример 2:
Результат формулы =(M25+I25*AG3+S25+O25*AG3)*0,001 из файла «pds.xslx» перенести в ячейку R8 файла «forecast.xlsx».
Результат формулы =(K57+I57*$AG$3)*0,001 из файла «pds.xslx» перенести в ячейку D9 файла «forecast.xlsx».
Результат формулы =(M57+I57*AG3)*0,001 из файла «pds.xslx» перенести в ячейку R9 файла «forecast.xlsx».
И так далее.

Макрос будет встроен в файл «forecast.xlsx» и данная операция будет выполнятся 1 раз в месяц.
Автор - Serj99
Дата добавления - 29.09.2015 в 15:38
Pelena Дата: Вторник, 29.09.2015, 16:53 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19197
Репутация: 4423 ±
Замечаний: ±

Excel 365 & Mac Excel
Serj99, шансы получить ответ увеличатся, если Вы приложите файлы с примерами

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеSerj99, шансы получить ответ увеличатся, если Вы приложите файлы с примерами
Автор - Pelena
Дата добавления - 29.09.2015 в 16:53
Serj99 Дата: Четверг, 01.10.2015, 14:19 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Цитата Pelena, 29.09.2015 в 16:53, в сообщении № 2
Serj99, шансы получить ответ увеличатся, если Вы приложите файлы с примерами


Файлы примеров прикрепил.
К сообщению приложен файл: pds.xlsx (50.7 Kb) · forecast.xlsx (31.7 Kb)


Сообщение отредактировал Serj99 - Четверг, 01.10.2015, 14:27
 
Ответить
Сообщение
Цитата Pelena, 29.09.2015 в 16:53, в сообщении № 2
Serj99, шансы получить ответ увеличатся, если Вы приложите файлы с примерами


Файлы примеров прикрепил.
Автор - Serj99
Дата добавления - 01.10.2015 в 14:19
Serj99 Дата: Вторник, 13.10.2015, 15:24 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Ждал ждал помощи, но не дождался и пришлось самому код писать :)
Прошу сильно не пинать - это мой первый код на VBA
[vba]
Код

Sub Forecast()
    Dim fPath As String
    Dim wbForecast As String
    Dim wbPDS As Object
    Dim sh As Object
    Dim Dni As Double
    fPath = ""
    fPath = ThisWorkbook.Path
    Set wbPDS = Workbooks.Open(Filename:=fPath & "\pds.xlsx")
'
'With Application
'    .ScreenUpdating = False
'    .DisplayAlerts = False
'    .Calculation = xlManual
'End With
'
With wbPDS
' Вычисляю остаток дней для формулы
    Range("AG3").FormulaLocal = "=День(КОНМЕСЯЦА(СЕГОДНЯ();0))-P1"
    Dni = Range("AG3").Value
'
' ЮНГ
' вычисляю формулу 1
    Range("AH7").FormulaLocal = "=(K25+I25*AG3+Q25+O25*AG3)*0,001"
' вычисляю формулу 2
    Range("AI7").FormulaLocal = "=(M25+I25*AG3+S25+O25*AG3)*0,001"
' вычисляю формулу 3
    Range("AH8").FormulaLocal = "=(K57+I57*AG3)*0,001"
' вычисляю формулу 4
    Range("AI8").FormulaLocal = "=(M57+I57*AG3)*0,001"
' вычисляю формулу 5
    Range("AH9").FormulaLocal = "=(Q57+O57*AG3)*0,001"
' вычисляю формулу 6
    Range("AI9").FormulaLocal = "=(S57+O57*AG3)*0,001"
End With
'
' Копирую в файл приемник
ThisWorkbook.ActiveWorkSheet.Range("D8").Value = wbPDS.Worksheets(1).Range("AI7").Value
ThisWorkbook.ActiveWorkSheet.Range("R8").Value = wbPDS.Worksheets(1).Range("AH7").Value
ThisWorkbook.ActiveWorkSheet.Range("D9").Value = wbPDS.Worksheets(1).Range("AI8").Value
ThisWorkbook.ActiveWorkSheet.Range("D9").Value = wbPDS.Worksheets(1).Range("AH8").Value
ThisWorkbook.ActiveWorkSheet.Range("D10").Value = wbPDS.Worksheets(1).Range("AI9").Value
ThisWorkbook.ActiveWorkSheet.Range("D10").Value = wbPDS.Worksheets(1).Range("AH9").Value
'
wbPDS.Close
Set wbPDS = Nothing
'
'With Application 'îïåðàöèè ñ ïðèëîæåíèåì/âêëþ÷àåì äëÿ ïîâûøåíèÿ ñêîðîñòè ðàáîòû ìàêðîñà
'    .ScreenUpdating = True 'îáíîâëåíèå ýêðàíà
'    .DisplayAlerts = True 'âûîä ñèñòåìíûõ ñîîáùåíèé
'    .Calculation = xlCalculationAutomatic 'àâòîïåðåñ÷åò ôîðìóë
'End With
'
End Sub
[/vba]

Теперь прошу помощи по корректировке написанного, т.к. когда выполняю макрос
система ругается на первую строку копирования данных в файл приемник
[vba]
Код
ThisWorkbook.ActiveWorkSheet.Range("D8").Value = wbPDS.Worksheets(1).Range("AI7").Value
[/vba]
 
Ответить
СообщениеЖдал ждал помощи, но не дождался и пришлось самому код писать :)
Прошу сильно не пинать - это мой первый код на VBA
[vba]
Код

Sub Forecast()
    Dim fPath As String
    Dim wbForecast As String
    Dim wbPDS As Object
    Dim sh As Object
    Dim Dni As Double
    fPath = ""
    fPath = ThisWorkbook.Path
    Set wbPDS = Workbooks.Open(Filename:=fPath & "\pds.xlsx")
'
'With Application
'    .ScreenUpdating = False
'    .DisplayAlerts = False
'    .Calculation = xlManual
'End With
'
With wbPDS
' Вычисляю остаток дней для формулы
    Range("AG3").FormulaLocal = "=День(КОНМЕСЯЦА(СЕГОДНЯ();0))-P1"
    Dni = Range("AG3").Value
'
' ЮНГ
' вычисляю формулу 1
    Range("AH7").FormulaLocal = "=(K25+I25*AG3+Q25+O25*AG3)*0,001"
' вычисляю формулу 2
    Range("AI7").FormulaLocal = "=(M25+I25*AG3+S25+O25*AG3)*0,001"
' вычисляю формулу 3
    Range("AH8").FormulaLocal = "=(K57+I57*AG3)*0,001"
' вычисляю формулу 4
    Range("AI8").FormulaLocal = "=(M57+I57*AG3)*0,001"
' вычисляю формулу 5
    Range("AH9").FormulaLocal = "=(Q57+O57*AG3)*0,001"
' вычисляю формулу 6
    Range("AI9").FormulaLocal = "=(S57+O57*AG3)*0,001"
End With
'
' Копирую в файл приемник
ThisWorkbook.ActiveWorkSheet.Range("D8").Value = wbPDS.Worksheets(1).Range("AI7").Value
ThisWorkbook.ActiveWorkSheet.Range("R8").Value = wbPDS.Worksheets(1).Range("AH7").Value
ThisWorkbook.ActiveWorkSheet.Range("D9").Value = wbPDS.Worksheets(1).Range("AI8").Value
ThisWorkbook.ActiveWorkSheet.Range("D9").Value = wbPDS.Worksheets(1).Range("AH8").Value
ThisWorkbook.ActiveWorkSheet.Range("D10").Value = wbPDS.Worksheets(1).Range("AI9").Value
ThisWorkbook.ActiveWorkSheet.Range("D10").Value = wbPDS.Worksheets(1).Range("AH9").Value
'
wbPDS.Close
Set wbPDS = Nothing
'
'With Application 'îïåðàöèè ñ ïðèëîæåíèåì/âêëþ÷àåì äëÿ ïîâûøåíèÿ ñêîðîñòè ðàáîòû ìàêðîñà
'    .ScreenUpdating = True 'îáíîâëåíèå ýêðàíà
'    .DisplayAlerts = True 'âûîä ñèñòåìíûõ ñîîáùåíèé
'    .Calculation = xlCalculationAutomatic 'àâòîïåðåñ÷åò ôîðìóë
'End With
'
End Sub
[/vba]

Теперь прошу помощи по корректировке написанного, т.к. когда выполняю макрос
система ругается на первую строку копирования данных в файл приемник
[vba]
Код
ThisWorkbook.ActiveWorkSheet.Range("D8").Value = wbPDS.Worksheets(1).Range("AI7").Value
[/vba]
Автор - Serj99
Дата добавления - 13.10.2015 в 15:24
Cheshir0067 Дата: Вторник, 13.10.2015, 15:35 | Сообщение № 5
Группа: Проверенные
Ранг: Новичок
Сообщений: 35
Репутация: 8 ±
Замечаний: 0% ±

Excel 2010
Привет попробуй так :
1 в начале до открытия новой книги вставь :
[vba]
Код

  Set main = ActiveWorkbook
[/vba]
2 вместо :
[vba]
Код

ThisWorkbook.ActiveWorkSheet.Range("D8").Value = wbPDS.Worksheets(1).Range("AI7").Value
[/vba]
вставь:
[vba]
Код

main.ActiveSheet.Range("D8").Value = wbPDS.Sheets(1).Range("A7")
[/vba]

irelandzp@gmail.com
 
Ответить
СообщениеПривет попробуй так :
1 в начале до открытия новой книги вставь :
[vba]
Код

  Set main = ActiveWorkbook
[/vba]
2 вместо :
[vba]
Код

ThisWorkbook.ActiveWorkSheet.Range("D8").Value = wbPDS.Worksheets(1).Range("AI7").Value
[/vba]
вставь:
[vba]
Код

main.ActiveSheet.Range("D8").Value = wbPDS.Sheets(1).Range("A7")
[/vba]
Автор - Cheshir0067
Дата добавления - 13.10.2015 в 15:35
Serj99 Дата: Вторник, 13.10.2015, 15:51 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Цитата Cheshir0067, 13.10.2015 в 15:35, в сообщении № 5
вставь:

main.ActiveSheet.Range("D8").Value = wbPDS.Sheets(1).Range("A7")


Все равно ошибка
К сообщению приложен файл: 8586517.png (12.6 Kb)
 
Ответить
Сообщение
Цитата Cheshir0067, 13.10.2015 в 15:35, в сообщении № 5
вставь:

main.ActiveSheet.Range("D8").Value = wbPDS.Sheets(1).Range("A7")


Все равно ошибка
Автор - Serj99
Дата добавления - 13.10.2015 в 15:51
miver Дата: Вторник, 13.10.2015, 15:58 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
Serj99, Как-то так для D8
[vba]
Код
Sub Forecast()
    Dim xlAp As New Excel.Application
    Dim xlWb As Excel.Workbook
    Dim Sh As Worksheet
    fPath = ThisWorkbook.Path
    Set xlWb = xlAp.Workbooks.Open(fPath & "\pds.xlsx")
    
    Set Sh = xlWb.ActiveSheet
    [D8] = Sh.[(K25+I25*AG3+Q25+O25*AG3)*0.001]
    
    xlWb.Close False
    xlAp.Quit
    
    Set xlWb = Nothing
    Set xlAp = Nothing
End Sub
[/vba]
К сообщению приложен файл: forecast.xlsm (40.2 Kb)


Сообщение отредактировал miver - Вторник, 13.10.2015, 15:59
 
Ответить
СообщениеSerj99, Как-то так для D8
[vba]
Код
Sub Forecast()
    Dim xlAp As New Excel.Application
    Dim xlWb As Excel.Workbook
    Dim Sh As Worksheet
    fPath = ThisWorkbook.Path
    Set xlWb = xlAp.Workbooks.Open(fPath & "\pds.xlsx")
    
    Set Sh = xlWb.ActiveSheet
    [D8] = Sh.[(K25+I25*AG3+Q25+O25*AG3)*0.001]
    
    xlWb.Close False
    xlAp.Quit
    
    Set xlWb = Nothing
    Set xlAp = Nothing
End Sub
[/vba]
Автор - miver
Дата добавления - 13.10.2015 в 15:58
Pelena Дата: Вторник, 13.10.2015, 16:02 | Сообщение № 8
Группа: Админы
Ранг: Местный житель
Сообщений: 19197
Репутация: 4423 ±
Замечаний: ±

Excel 365 & Mac Excel
Цитата Serj99, 13.10.2015 в 15:24, в сообщении № 4
система ругается на первую строку копирования данных в файл приемник

Ругается на ActiveWorkSheet, надо ActiveSheet

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщение
Цитата Serj99, 13.10.2015 в 15:24, в сообщении № 4
система ругается на первую строку копирования данных в файл приемник

Ругается на ActiveWorkSheet, надо ActiveSheet
Автор - Pelena
Дата добавления - 13.10.2015 в 16:02
Serj99 Дата: Вторник, 13.10.2015, 16:10 | Сообщение № 9
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Цитата Pelena, 13.10.2015 в 16:02, в сообщении № 8
Ругается на ActiveWorkSheet, надо ActiveSheet

Уже поменял на [vba]
Код
main.ActiveSheet.Range("D8").Value = wbPDS.Sheets(1).Range("A7")
[/vba]
Все равно не помогло сейчас потестим вариант от miver
 
Ответить
Сообщение
Цитата Pelena, 13.10.2015 в 16:02, в сообщении № 8
Ругается на ActiveWorkSheet, надо ActiveSheet

Уже поменял на [vba]
Код
main.ActiveSheet.Range("D8").Value = wbPDS.Sheets(1).Range("A7")
[/vba]
Все равно не помогло сейчас потестим вариант от miver
Автор - Serj99
Дата добавления - 13.10.2015 в 16:10
Pelena Дата: Вторник, 13.10.2015, 16:12 | Сообщение № 10
Группа: Админы
Ранг: Местный житель
Сообщений: 19197
Репутация: 4423 ±
Замечаний: ±

Excel 365 & Mac Excel
Я имела в виду Ваш изначальный код (без main)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЯ имела в виду Ваш изначальный код (без main)
Автор - Pelena
Дата добавления - 13.10.2015 в 16:12
Serj99 Дата: Вторник, 13.10.2015, 16:39 | Сообщение № 11
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Цитата удалена

miver, Ваш код подвешивает мой комп минут на пять а потом вот такое сообщение получаю
[moder]Не надо цитировать пост целиком. Это нарушение Правил форума[/moder]
К сообщению приложен файл: 4647580.png (27.4 Kb)


Сообщение отредактировал Pelena - Вторник, 13.10.2015, 16:59
 
Ответить
СообщениеЦитата удалена

miver, Ваш код подвешивает мой комп минут на пять а потом вот такое сообщение получаю
[moder]Не надо цитировать пост целиком. Это нарушение Правил форума[/moder]
Автор - Serj99
Дата добавления - 13.10.2015 в 16:39
Serj99 Дата: Вторник, 13.10.2015, 16:59 | Сообщение № 12
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Pelena, Ваша поправка действительно сработала :D
Можете пояснить почему нужно было использовать ActiveSheet?
 
Ответить
СообщениеPelena, Ваша поправка действительно сработала :D
Можете пояснить почему нужно было использовать ActiveSheet?
Автор - Serj99
Дата добавления - 13.10.2015 в 16:59
Pelena Дата: Вторник, 13.10.2015, 17:06 | Сообщение № 13
Группа: Админы
Ранг: Местный житель
Сообщений: 19197
Репутация: 4423 ±
Замечаний: ±

Excel 365 & Mac Excel
Насколько я знаю, свойства ActiveWorkSheet в принципе не существует :)

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеНасколько я знаю, свойства ActiveWorkSheet в принципе не существует :)
Автор - Pelena
Дата добавления - 13.10.2015 в 17:06
Serj99 Дата: Вторник, 13.10.2015, 17:41 | Сообщение № 14
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Всем спасибо - вопрос закрыт! hands victory first yahoo closed
 
Ответить
СообщениеВсем спасибо - вопрос закрыт! hands victory first yahoo closed
Автор - Serj99
Дата добавления - 13.10.2015 в 17:41
Serj99 Дата: Четверг, 15.10.2015, 13:40 | Сообщение № 15
Группа: Пользователи
Ранг: Прохожий
Сообщений: 9
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Появился дополнительный вопрос по этой же теме.
Как можно оптимизировать написаный код?
Например, хотелось бы не делать промежуточные вычисления, а сразу вычислять и вставлять полученный результат в ячейки файла приемника.
 
Ответить
СообщениеПоявился дополнительный вопрос по этой же теме.
Как можно оптимизировать написаный код?
Например, хотелось бы не делать промежуточные вычисления, а сразу вычислять и вставлять полученный результат в ячейки файла приемника.
Автор - Serj99
Дата добавления - 15.10.2015 в 13:40
miver Дата: Пятница, 16.10.2015, 09:18 | Сообщение № 16
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 190
Репутация: 37 ±
Замечаний: 0% ±

Excel 2010
Цитата Serj99, 13.10.2015 в 16:39, в сообщении № 11
Ваш код подвешивает мой комп минут на пять
Странно <_< Должно отработать без проблем.
Попробуйте такой вариант
[vba]
Код
Sub Forecast()
    On Error GoTo er
    Dim xlAp As New Excel.Application
    Dim xlWb As Excel.Workbook
    Dim Sh As Worksheet
    fPath = ThisWorkbook.Path
    Set xlWb = xlAp.Workbooks.Open(fPath & "\pds.xlsx")
    xlAp.Calculation = xlCalculationManual
    xlAp.DisplayStatusBar = False
    xlAp.DisplayAlerts = False
    
    Set Sh = xlWb.ActiveSheet
    [D8] = Sh.[(K25+I25*AG3+Q25+O25*AG3)*0.001]
    'Лист1.Range("D8").Value = (Sh.Range("K25").Value + Sh.Range("I25").Value * Sh.Range("AG3").Value + _
                            Sh.Range("Q25").Value + Sh.Range("O25").Value * Sh.Range("AG3").Value) * 0.001
    
    xlAp.Calculation = xlCalculationAutomatic
    xlAp.DisplayStatusBar = True
    xlAp.DisplayAlerts = True
    xlWb.Close False
    xlAp.Quit
    
    Set xlWb = Nothing
    Set xlAp = Nothing
Exit Sub
er:
    xlAp.Calculation = xlCalculationAutomatic
    xlAp.DisplayStatusBar = True
    xlAp.DisplayAlerts = True
    xlWb.Close False
    xlAp.Quit
    If Err.Number <> 0 Then
        Msg = "Error # " & Str(Err.Number) & " was generated by " _
                & Err.Source & Chr(13) & Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
End Sub
[/vba]
Если не заработает, поменяйте строчку вычислений на
[vba]
Код
Лист1.Range("D8").Value = (Sh.Range("K25").Value + Sh.Range("I25").Value * Sh.Range("AG3").Value + _
                            Sh.Range("Q25").Value + Sh.Range("O25").Value * Sh.Range("AG3").Value) * 0.001
[/vba]
розкоментируйте. Вобщем должно быть понятно
К сообщению приложен файл: 959595.zip (85.6 Kb)
 
Ответить
Сообщение
Цитата Serj99, 13.10.2015 в 16:39, в сообщении № 11
Ваш код подвешивает мой комп минут на пять
Странно <_< Должно отработать без проблем.
Попробуйте такой вариант
[vba]
Код
Sub Forecast()
    On Error GoTo er
    Dim xlAp As New Excel.Application
    Dim xlWb As Excel.Workbook
    Dim Sh As Worksheet
    fPath = ThisWorkbook.Path
    Set xlWb = xlAp.Workbooks.Open(fPath & "\pds.xlsx")
    xlAp.Calculation = xlCalculationManual
    xlAp.DisplayStatusBar = False
    xlAp.DisplayAlerts = False
    
    Set Sh = xlWb.ActiveSheet
    [D8] = Sh.[(K25+I25*AG3+Q25+O25*AG3)*0.001]
    'Лист1.Range("D8").Value = (Sh.Range("K25").Value + Sh.Range("I25").Value * Sh.Range("AG3").Value + _
                            Sh.Range("Q25").Value + Sh.Range("O25").Value * Sh.Range("AG3").Value) * 0.001
    
    xlAp.Calculation = xlCalculationAutomatic
    xlAp.DisplayStatusBar = True
    xlAp.DisplayAlerts = True
    xlWb.Close False
    xlAp.Quit
    
    Set xlWb = Nothing
    Set xlAp = Nothing
Exit Sub
er:
    xlAp.Calculation = xlCalculationAutomatic
    xlAp.DisplayStatusBar = True
    xlAp.DisplayAlerts = True
    xlWb.Close False
    xlAp.Quit
    If Err.Number <> 0 Then
        Msg = "Error # " & Str(Err.Number) & " was generated by " _
                & Err.Source & Chr(13) & Err.Description
        MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
    End If
End Sub
[/vba]
Если не заработает, поменяйте строчку вычислений на
[vba]
Код
Лист1.Range("D8").Value = (Sh.Range("K25").Value + Sh.Range("I25").Value * Sh.Range("AG3").Value + _
                            Sh.Range("Q25").Value + Sh.Range("O25").Value * Sh.Range("AG3").Value) * 0.001
[/vba]
розкоментируйте. Вобщем должно быть понятно
Автор - miver
Дата добавления - 16.10.2015 в 09:18
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос переноса данных с промежуточным вычислением (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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