Страницы: 1
RSS
Перенести данные из таблици в другую книгу в первую незаполненую строку.
 
Добрый день, форумчане!
У меня такая проблема по написанию макроса.
Есть книга "ТЧ" в ней заполняются ячейки, надо перенести данные в в таблицу  книге "Отчет"  в первую не заполненную строку.
Вот, что я пытался написать. Если кто может поправьте. Буду очень признателен.
Код
Sub ПеренесстиВОтчетИП()

Dim firstBook As Workbook
Dim secondBook As Workbook
Set firstBook = ThisWorkbook
Set secondBook = ActiveWorkbook

On Error Resume Next
Application.ScreenUpdating = False
Set firstBook = Workbooks.Open("C:\Users\Владимир\Desktop\Отчет.xlsb")
 'Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Отчет.xlsb") ' Пр
Row = 2
    Do While secondBook.Worksheets("Отчет").Cells(Row, 2).Value <> 0
        Row = Row + 1
    Loop
  lLastRow = Cells(1, 2).End(xlDown).Row
    secondBook.Worksheets("Отчет").Cells(Row, 2).Value = firstBook.Worksheets("Лист1").Cells(8, 4).Value + 0 'Номер Тов чек
    secondBook.Worksheets("Отчет").Cells(Row, 3).Value = firstBook.Worksheets("Лист1").Cells(9, 7).Value 'Дата
   
    secondBook.Worksheets("Отчет").Cells(Row, 1).Value = firstBook.Worksheets("Лист1").Cells(38, 5).Value 'Клиент'
    secondBook.Worksheets("Отчет").Cells(Row, 4).Value = firstBook.Worksheets("Лист1").Cells(39, 5).Value 'Адрес
    secondBook.Worksheets("Отчет").Cells(Row, 7).Value = firstBook.Worksheets("Лист1").Cells(40, 5).Value 'Договор
   
    secondBook.Worksheets("Отчет").Cells(Row, 6).Value = firstBook.Worksheets("Лист1").Cells(59, 7).Value 'Товар или работы. Через доп ячейку

Application.ScreenUpdating = True
End Sub
Изменено: Владимир S - 29.03.2018 15:56:43
 
Кто то может подскажет? Где ошибки?
 
А в чем проблема? Вам ошибку выдает или как?
"Все гениальное просто, а все простое гениально!!!"
 
если у вас макрос на кнопке, то
Код
Set firstBook = ThisWorkbook
Set secondBook = ActiveWorkbook
этим переменным присваивается одна и та же книга.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim Спасибо, что ответили. Проблема в том, что Книгу  "Отчет"  открывает, но в нее ничего не переносит. Ошибку ни какую не показывает. (проверял  через F8)
 
Да, макрос на кнопке. Подскажите пожалуйста, как поправить, что бы присваивалось разным книгам?
Изменено: Владимир S - 29.03.2018 22:53:02
 
Код
Option Explicit

Sub PerenestiWOtchetIP()
Dim lLastRow As Long
Dim firstBook As Workbook, secondBook As Workbook

    Application.ScreenUpdating = False
    
    Set firstBook = ThisWorkbook
    Set secondBook = Workbooks.Open("C:\Temp\Otchet.xls") '"C:\Users\Vladimir\Desktop\Otchet.xlsb"
    
    With secondBook
        With .Worksheets("Otchet")
            lLastRow = .Cells(.Rows.Count, "a").End(xlUp).Row + 1
            
            .Cells(lLastRow, 1).Value = firstBook.Worksheets("List1").Cells(38, 5).Value 'Klient'
            .Cells(lLastRow, 2).Value = firstBook.Worksheets("List1").Cells(8, 4).Value + 0 'Nomer tov chek
            .Cells(lLastRow, 3).Value = firstBook.Worksheets("List1").Cells(9, 7).Value 'Data
            .Cells(lLastRow, 4).Value = firstBook.Worksheets("List1").Cells(39, 5).Value 'Adres
            '
            .Cells(lLastRow, 6).Value = firstBook.Worksheets("List1").Cells(59, 7).Value 'Tovar ili raboty. Cherez dop
            .Cells(lLastRow, 7).Value = firstBook.Worksheets("List1").Cells(40, 5).Value 'Dogovor
        End With
        .Close True
    End With
    
    Application.ScreenUpdating = True
End Sub
Изменено: ocet p - 29.03.2018 23:09:31
 
Попробуйте так!
Код
Sub ПеренесстиВОтчетИП()
    Dim sht As Worksheet
    Dim iPath$, lRow&
    Set sht = ThisWorkbook.Worksheets("Отчет")
    iPath = Application.GetOpenFilename("(*.xls*),*.xls*")
    With GetObject(iPath).Worksheets("Лист1")
        lRow = sht.Range("a" & sht.Rows.Count).End(xlUp).Row + 1
        sht.Cells(lRow, 2).Value = .Cells(8, 4).Value + 0   'Номер Тов чек
        sht.Cells(lRow, 3).Value = .Cells(9, 7).Value       'Дата
        sht.Cells(lRow, 1).Value = .Cells(38, 5).Value       'Клиент'
        sht.Cells(lRow, 4).Value = .Cells(39, 5).Value       'Адрес
        sht.Cells(lRow, 7).Value = .Cells(40, 5).Value       'Договор
        sht.Cells(lRow, 6).Value = .Cells(59, 7).Value       'Товар или работы. Через доп ячейку
        .Parent.Close False
    End With
End Sub

Макрос добавляете в файл отчет. Файл из которого будут переносится данные выбираете, если это не нужно то можете жестко прописать путь к файлу ТЧ.xlsb
"Все гениальное просто, а все простое гениально!!!"
 
ocet p,NordheimБольшое спасибо за участие, за решение. Все получилось я выбрал вариант  ocet p  По варианту Nordheim  буду разбегаться попозже.
Разобрался, но мне надо запускать макрос из Книги "ТЧ".А так все работает хорошо.
Еще раз всем огромное спасибо.
Изменено: Владимир S - 30.03.2018 21:14:53
 
Цитата
Владимир S написал:
надо запускать макрос из Книги "ТЧ".
Если запускать макрос из книги ТЧ, то макрос из сообщения 8 не подходит.
По моему опыту как правило в файл отчет собирают данные из нескольких файлов, поэтому и код был написан для работы по данному алгоритму.
Изменено: Nordheim - 30.03.2018 21:43:22
"Все гениальное просто, а все простое гениально!!!"
 
NordheimПоясню. Здесь немного не так. Книга ТЧ это выписка товарных чеков.  Книга Отчет собираются все сделки включая, как по безналичному так и наличному расчету. Когда выписывается товарный чек он автоматически отправляется в Книгу Отчет.  Алгоритм такой нажал на кнопку Печать товарного чека, он сразу попал в Отчет.
Спасибо.
Изменено: Владимир S - 31.03.2018 09:10:49
 
Код
Sub ПеренесстиВОтчетИП()
    Dim sht As Worksheet
    Dim iPath$, lRow&
    Application.ScreenUpdating = False
    Set sht = ThisWorkbook.Worksheets("Лист1")
    iPath = Application.GetOpenFilename("(*.xls*),*.xls*")
    With GetObject(iPath).Worksheets("Отчет")
        lRow = .Range("a" & sht.Rows.Count).End(xlUp).Row + 1
        .Cells(lRow, 2).Value = sht.Cells(8, 4).Value + 0   'Номер Тов чек
        .Cells(lRow, 3).Value = sht.Cells(9, 7).Value       'Дата
        .Cells(lRow, 1).Value = sht.Cells(38, 5).Value       'Клиент'
        .Cells(lRow, 4).Value = sht.Cells(39, 5).Value       'Адрес
        .Cells(lRow, 7).Value = sht.Cells(40, 5).Value       'Договор
        .Cells(lRow, 6).Value = sht.Cells(59, 7).Value       'Товар или работы. Через доп ячейку
        Windows(.Parent.Name).Visible = True
        .Parent.Close True
    End With
    Application.ScreenUpdating = True
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
NordheimПрекрасно работает.
Большое спасибо.
Страницы: 1
Наверх