Доброго дня всем! Помогите написать код макроса для следующей задачи. Есть два документа формата 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
Ждал ждал помощи, но не дождался и пришлось самому код писать :) Прошу сильно не пинать - это мой первый код на 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]
Ждал ждал помощи, но не дождался и пришлось самому код писать :) Прошу сильно не пинать - это мой первый код на 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]
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]
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]
miver, Ваш код подвешивает мой комп минут на пять а потом вот такое сообщение получаю [moder]Не надо цитировать пост целиком. Это нарушение Правил форума[/moder]
Цитата удалена
miver, Ваш код подвешивает мой комп минут на пять а потом вот такое сообщение получаю [moder]Не надо цитировать пост целиком. Это нарушение Правил форума[/moder]Serj99
Появился дополнительный вопрос по этой же теме. Как можно оптимизировать написаный код? Например, хотелось бы не делать промежуточные вычисления, а сразу вычислять и вставлять полученный результат в ячейки файла приемника.
Появился дополнительный вопрос по этой же теме. Как можно оптимизировать написаный код? Например, хотелось бы не делать промежуточные вычисления, а сразу вычислять и вставлять полученный результат в ячейки файла приемника.Serj99
Странно Должно отработать без проблем. Попробуйте такой вариант [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
Странно Должно отработать без проблем. Попробуйте такой вариант [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