Sub Заявка() ' ' Заявка Макрос ' Макрос записан 23.12.2013 (Юрченко Александр) '
а = Range("Object1") ' АУП b = Range("Object2") ' Объект с = Range("Quatro") ' Квартал d = Range("Position") ' Количество позиций в заявке z = Range("Data") ' Дата заявки q = Range("PositionEnd") + 1 For i = 0 To d - 1 w = 12 + 2 * i ' строка заявки e = Cells(w, 3) ' Номенклатурная позиция f = Cells(w, 4) + " " + Cells(w + 1, 4) ' Наименование МТР g = Cells(w, 5) ' Количество h = Cells(w, 6) ' Единицы измерения j = Cells(w + 1, 7) ' Примечание Workbooks("Заявки ОМТО.xls").Activate Cells(q, 2) = b Cells(q, 6) = e ''''''''''''''' Workbooks("План.xls").Activate q = q + 1 Next i End Sub
[/vba]
похоже вот он
[vba]
Код
Attribute VB_Name = "Module1"
Sub Заявка() ' ' Заявка Макрос ' Макрос записан 23.12.2013 (Юрченко Александр) '
а = Range("Object1") ' АУП b = Range("Object2") ' Объект с = Range("Quatro") ' Квартал d = Range("Position") ' Количество позиций в заявке z = Range("Data") ' Дата заявки q = Range("PositionEnd") + 1 For i = 0 To d - 1 w = 12 + 2 * i ' строка заявки e = Cells(w, 3) ' Номенклатурная позиция f = Cells(w, 4) + " " + Cells(w + 1, 4) ' Наименование МТР g = Cells(w, 5) ' Количество h = Cells(w, 6) ' Единицы измерения j = Cells(w + 1, 7) ' Примечание Workbooks("Заявки ОМТО.xls").Activate Cells(q, 2) = b Cells(q, 6) = e ''''''''''''''' Workbooks("План.xls").Activate q = q + 1 Next i End Sub
Открыл в десятом, пересохранил в третьем. Как-то так:
[vba]
Код
Sub Заявка() Dim f As Boolean, wb As Workbook ' ' Заявка Макрос ' Макрос записан 23.12.2013 (Юрченко Александр) On Error Resume Next Set b = Workbooks("Свод.xls") If Not b Is Nothing Then f = -1 On Error goto 0 Set wb = GetObject(ThisWorkbook.Path & "\Свод.xls") With ThisWorkbook а = .Range("Object1") ' АУП d = .Range("Position") ' Количество позиций в заявке z = .Range("Data") ' Дата заявки q = .Range("PositionEnd") + 1 For i = 0 To d - 1 w = 12 + 2 * i ' строка заявки ' e = .Cells(w, 3) ' Номенклатурная позиция ' f = .Cells(w, 4) + " " + Cells(w + 1, 4) ' Наименование МТР ' g = .Cells(w, 5) ' Количество ' h = .Cells(w, 6) ' Единицы измерения ' j = .Cells(w + 1, 7) 'убрать нафиг все переменные и присваивать значения напрямую, как дальше: wb.Cells(q, 2) = .Range("Object2") ' Объект wb.Cells(q, 6) = .Range("Quatro") ' Квартал '... ''''''''''''''' q = q + 1 Next i End With If f Then wb.Save Else Windows("Свод.xls").Visible = -1 wb.Close -1 End If End Sub
[/vba]
Дальше что куда копировать заполните сами, пару строк я для примера показал. Путь: ThisWorkbook.Path & "\Свод.xls" поменяйте на свой, хотя так гораздо лучше. При любом перемещении путь будет рабочим.
Открыл в десятом, пересохранил в третьем. Как-то так:
[vba]
Код
Sub Заявка() Dim f As Boolean, wb As Workbook ' ' Заявка Макрос ' Макрос записан 23.12.2013 (Юрченко Александр) On Error Resume Next Set b = Workbooks("Свод.xls") If Not b Is Nothing Then f = -1 On Error goto 0 Set wb = GetObject(ThisWorkbook.Path & "\Свод.xls") With ThisWorkbook а = .Range("Object1") ' АУП d = .Range("Position") ' Количество позиций в заявке z = .Range("Data") ' Дата заявки q = .Range("PositionEnd") + 1 For i = 0 To d - 1 w = 12 + 2 * i ' строка заявки ' e = .Cells(w, 3) ' Номенклатурная позиция ' f = .Cells(w, 4) + " " + Cells(w + 1, 4) ' Наименование МТР ' g = .Cells(w, 5) ' Количество ' h = .Cells(w, 6) ' Единицы измерения ' j = .Cells(w + 1, 7) 'убрать нафиг все переменные и присваивать значения напрямую, как дальше: wb.Cells(q, 2) = .Range("Object2") ' Объект wb.Cells(q, 6) = .Range("Quatro") ' Квартал '... ''''''''''''''' q = q + 1 Next i End With If f Then wb.Save Else Windows("Свод.xls").Visible = -1 wb.Close -1 End If End Sub
[/vba]
Дальше что куда копировать заполните сами, пару строк я для примера показал. Путь: ThisWorkbook.Path & "\Свод.xls" поменяйте на свой, хотя так гораздо лучше. При любом перемещении путь будет рабочим.KuklP
Ну с НДС и мы чего-то стoим! kuklp60@gmail.com WM Z206653985942, R334086032478, U238399322728
Сообщение отредактировал KuklP - Вторник, 24.12.2013, 14:25
Прикольно. Мне, чтоб Вам помочь надо еще и защиту на ВБА проект сломать?
Защита на проекте VBA в файлах стоит... могу снять, только зачем? У меня модуль сидит в Personal (с горем пополам, но пашет - во вложении - пока обошелся малой кровью), привязан к кнопочке на панельке инструментов Excel. Задача - максимально упростить переключения.
Прикольно. Мне, чтоб Вам помочь надо еще и защиту на ВБА проект сломать?
Защита на проекте VBA в файлах стоит... могу снять, только зачем? У меня модуль сидит в Personal (с горем пополам, но пашет - во вложении - пока обошелся малой кровью), привязан к кнопочке на панельке инструментов Excel. Задача - максимально упростить переключения.
Осталось понять что он ругается на а = .Range("Object1") ' - пишет, что объект не поддерживает данное свойство или метод. у меня 2003-й офис. И наотрез отказывается выполнять wb.Cells(q, 2) = .Range("Object2") ' - ошибка, аналогичная предыдущей
Осталось понять что он ругается на а = .Range("Object1") ' - пишет, что объект не поддерживает данное свойство или метод. у меня 2003-й офис. И наотрез отказывается выполнять wb.Cells(q, 2) = .Range("Object2") ' - ошибка, аналогичная предыдущейShnur1979
Сообщение отредактировал Shnur1979 - Вторник, 24.12.2013, 15:19
а на самом деле он у Вас из персоналки запускается.
до этого я допедрил... только вместо With Workbooks("Заявка.xls") поставил ActiveWorkbook также, убрал точку перед Range - начал присваивать значения переменным... а вот чтоб напрямую в другую книгу значения перетаскивались не могу победить.
а на самом деле он у Вас из персоналки запускается.
до этого я допедрил... только вместо With Workbooks("Заявка.xls") поставил ActiveWorkbook также, убрал точку перед Range - начал присваивать значения переменным... а вот чтоб напрямую в другую книгу значения перетаскивались не могу победить.Shnur1979
RAN, в данном конкретном случае - это те же яйца, только вид сбоку, т.к. макрос запускается с АКТИВНОЙ книги с именем "Заявка.xls" Только что поставил в код With Workbooks("Заявка.xls"), вернул на место точки перед Range - получил Run-time 438 VBA у меня заколдованный что ли...............? - ума не приложу что ему не так?
RAN, в данном конкретном случае - это те же яйца, только вид сбоку, т.к. макрос запускается с АКТИВНОЙ книги с именем "Заявка.xls" Только что поставил в код With Workbooks("Заявка.xls"), вернул на место точки перед Range - получил Run-time 438 VBA у меня заколдованный что ли...............? - ума не приложу что ему не так?Shnur1979