Страницы: 1 2 След.
RSS
Цикл открывающий файлы Excel и копирующий определенные ячейки в файл с кодом, Применение циклов
 
Добрый день!

Есть задача:
1) Открывать файлы с помощью цикла
2) Копировать определенные ячейки из разных мест на листе.

3) Вставлять в список в книгу с кодом Macro.xlsm (ThisWorkbook) следующую пустую строку по столбцам А и B.

Код не работает. Идет Run, потом пропадает окно с кодом, но VBE остается. То же самое с Листом ThisWorkbook, только серая область, без разметки.

Код
Sub KopirovanieIVstavkaVSpisok()
Dim s As String, MyFiles As String, MyRange As String, MyRange2 As String, wb As Workbook


Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False

MyFiles = "C:\Users\User\Desktop\Papka3\"
s = Dir(MyFiles & "*.xls")
Do While s <> ""
    With Workbooks.Open(MyFiles & s)
        
        ' To copy file
        Set wb = Workbooks.Open(MyFiles & s)
        Range("D1").Select ' .Worksheets("Лист1").
        Selection.Copy
                        
        ' To insert file
        ThisWorkbook.Worksheets("Лист2").Select
        MyRange = "A" & ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        ThisWorkbook.Worksheets("Лист2").Range(MyRange).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        
        ' To copy file
        Set wb = Workbooks.Open(MyFiles & s)
        Range("G8").Select ' .Worksheets("Лист1").
        Selection.Copy
        
        ' To insert file
        ThisWorkbook.Worksheets("Лист2").Select
        MyRange2 = "B" & ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        ThisWorkbook.Worksheets("Лист2").Range(MyRange2).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        
        .Close SaveChanges:=True
        
    End With
    s = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True

End Sub
Изменено: Spec - 02.10.2020 17:37:02
 
Точно не знаю, но вот в этой строке вы обрабатываете (открываете) только файлы со старым форматом Excel.
Код
s = Dir(MyFiles & "*.xls")

лучше прописать так
Код
s = Dir(MyFiles & "*.xls*")

Вы можете весь код пройтись построчно. Это делается кнопкой F8 (сперва поставить курсор мыши в любое место вашего кода)
Изменено: New - 02.10.2020 17:34:33
 
New,Применил
s = Dir(MyFiles & "*.xls*")
Также прошелся по F8, серая область только.
 
Код
    With Workbooks.Open(MyFiles & s)
         
        ' To copy file
        Set wb = Workbooks.Open(MyFiles & s)

ну тут явно что-то лишнее...
Код проверил - если файл есть, то нормально открывается, окно не серое. Если конечно этот файл не сохранён с скрытым окном! А может он остался в таком виде открытым после предыдущих экспериментов с getobject()?
Изменено: Hugo - 02.10.2020 17:47:34
 
Hugo,А что лишнее With или Set?))) Две операции с копированием двух ячеек на разных местах как сделать?
 
Hugo,Если убрать with пишет compile error
 
Я там выше чуть дописал...
 
Цитата
Spec написал:
А что лишнее With или Set?
- вообще оба, Вы ни одно ни другое не используете :) Но одно оставьте, лучше первое, чтоб файл всёж открылся.
Да, первое оставьте, там ниже всёж есть
Код
.Close SaveChanges:=True
Изменено: Hugo - 02.10.2020 17:50:28
 
Hugo,компьютер перезагрузить нужно?   Скрытое окно - это что такое?
Изменено: Spec - 02.10.2020 17:51:56
 
Скрытое окно - это когда меню вид - окно - скрыть!
Если в коде использовали getobject() - то файл открывается в таком виде. Если файл там же и сохранили - значит в таком виде и сохранили. Если не закрыли - ну значит он в таком виде и открыт.
Так что надёжнее перезагрузить.
Изменено: Hugo - 02.10.2020 17:56:47
 
Hugo, оба Set сделать комментарием?
Изменено: Spec - 02.10.2020 18:02:45
 
И чо? 28-ю строку забыли!
Перепостите код в русской раскладке - кириллица поехала...
Изменено: Hugo - 02.10.2020 18:00:40
 
Hugo,15 и 28 строку сделал комментариями, все равно не работает.
 
Не работает каким образом? :)
 
Hugo,Как на прикрепленном файле jpeg. Серый фон в VBE.
 
Если открываете файл вручную - что с фоном?
Стоп, это ведь VBE (не вижу нифига уже в таких картинках...) - а почему это Вас волнует? Зачем оно нужно?
У меня всё ОК, похоже что у Вас глюк. Может что с офисом...
Изменено: Hugo - 02.10.2020 18:52:28
 
Hugo,Нормально, все файлы вид, сделал обычный.
 
Hugo,Даже когда удалаи с 17 по 38 строки, чтобы только выделял ячейку и сохранял при закрытии. Быстро проверить цикл. Тоже самое серый фон. Но другие макросы работают.
 
Почему Вас это волнует?
 
Hugo,После того как перезагрузил компьютер, и очистил комп с CCleaner, пишет Runtime Error 1004 на 20 строку ThisWorkbook.Worksheets("Лист2").Select

Метод Select из класса Worksheet завершен неверно - пишет excel.
Изменено: Spec - 02.10.2020 19:04:48
 
Где расположен код?
 
Hugo, файл Macro.xlsm     (ThisWorkbook)
 
Если уж Вы так упорно применяете всюду селекты, то не нужно забывать и про активацию:
Код
            ' To insert file
            ThisWorkbook.Activate
            ThisWorkbook.Worksheets("Лист2").Select

У Вас ведь в этот момент активна открытая книга!
А вообще уходите от селектов и активаций, пишите код без них. Как - см. форумы или книги. Лучше форумы :)
Изменено: Hugo - 02.10.2020 19:30:34
 
Hugo,29 строку как активировать после thisworkbook.Activate ? Ведь остается активированной только Thisworkbook, а надо переключиться.  Workbooks.Open(MyFiles & s).Activate не подойдет ведь.
Изменено: Spec - 02.10.2020 19:38:50
 
Вообще т.к. копируете только значения, то весь этот код можно сократить раз так в 10. Сейчас...
Вот, лишнее закомментил. Кстати, у меня открывает и xlsx, и xlsm...
Код
Sub KopirovanieIVstavkaVSpisok()
    Dim s As String, MyFiles As String ', MyRange As String, MyRange2 As String, wb As Workbook


    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.AskToUpdateLinks = False

    MyFiles = "C:\Users\User\Desktop\Papka3\"
    s = Dir(MyFiles & "*.xls")
    Do While s <> ""
        With Workbooks.Open(MyFiles & s)

            ' To copy file
            il = ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
            ThisWorkbook.Worksheets("Лист2").Cells(il, 1) = .ActiveSheet.Cells(1, 4)
            '            Range("D1").Select    ' .Worksheets("Лист1").
            '            Selection.Copy

            '            ' To insert file
            '            ThisWorkbook.Activate
            '            ThisWorkbook.Worksheets("Лист2").Select
            '            MyRange = "A" & ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
            '            ThisWorkbook.Worksheets("Лист2").Range(MyRange).Select
            '            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                         '                                                                          :=False, Transpose:=False

            il = il + 1
            ThisWorkbook.Worksheets("Лист2").Cells(il, 2) = .ActiveSheet.Cells(8, 7)

            '            ' To copy file
            '            Set wb = Workbooks.Open(MyFiles & s)
            '            Range("G8").Select    ' .Worksheets("Лист1").
            '            Selection.Copy
            '
            '            ' To insert file
            '            ThisWorkbook.Activate
            '            ThisWorkbook.Worksheets("Лист2").Select
            '            MyRange2 = "B" & ThisWorkbook.Worksheets("Лист2").Cells.SpecialCells(xlCellTypeLastCell).Row + 1
            '            ThisWorkbook.Worksheets("Лист2").Range(MyRange2).Select
            '            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                         '                                                                          :=False, Transpose:=False

            .Close 0 '!!!! SaveChanges:=True

        End With
        s = Dir
    Loop

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.AskToUpdateLinks = True

End Sub
Изменено: Hugo - 02.10.2020 19:55:31
 
Hugo,Через строку идет вставка в Вашем новом коде A1, A3, A5  B1, B3, B5/              а нужно чтобы шло порядку А1, A2, A3   B1, B2, B3
 
Я делал как Вы код написали, как он работал (должен был работать) так и мой работает!
Опоздали Вы с описанием, теперь всё :(
Сами разбирайтесь какую одну строку нужно убрать. :)
Изменено: Hugo - 02.10.2020 20:02:03
 
Цитата
Spec написал:
Серый фон в VBE
Цитата
Hugo написал:
Стоп, это ведь VBE
А на картинке, внизу, - активен Excel. М.б. всё же VBA? :)

Далее.
В строке 16 кода вы берете и копируете значение не из Лист1, а из активного листа книги, из которой запускаете макрос.
Но Вы же хотите копировать из только что открытой книги.
Всё проверить нет возможности, но вот такой код - будет правильнее Вашего.
Чтобы каждый раз не писать ThisWorkbook.Worksheets("Лист2"), лучше объявить переменную и присвоить ей этот объект. Я применил переменную Sh
Код
Sub KopirovanieIVstavkaVSpisok()
Dim s As String, MyFiles As String, MyRange As String, MyRange2 As String, wb As Workbook, sh As Worksheet


Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.AskToUpdateLinks = False

Set sh = ThisWorkbook.Worksheets("Лист2")
MyFiles = "C:\Users\User\Desktop\Papka3\"
s = Dir(MyFiles & "*.xls")
Do While s <> ""
    Set wb = Workbooks.Open(MyFiles & s)
    With wb
        
        ' To copy file
        .Worksheets("Лист1").Range("D1").Copy
                        
        ' To insert file
        sh.Select
        MyRange = "A" & sh.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
        sh.Range(MyRange).PasteSpecial Paste:=xlPasteValues, _
                                       Operation:=xlNone, _
                                       SkipBlanks:=False, _
                                       Transpose:=False
        
        
        ' To copy file
'        Set wb = Workbooks.Open(MyFiles & s)
        .Worksheets("Лист1").Range("G8").Copy
        
        ' To insert file
        sh.Select
        MyRange2 = "B" & sh.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
'        sh.Range(MyRange2).Select
'        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'            :=False, Transpose:=False
        sh.Range(MyRange).PasteSpecial Paste:=xlPasteValues, _
                                       Operation:=xlNone, _
                                       SkipBlanks:=False, _
                                       Transpose:=False
        
        .Close SaveChanges:=True
        
    End With
    s = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.AskToUpdateLinks = True

End Sub
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
Цитата
Михаил Лебедев написал:
М.б. всё же VBA?
Visual Basic Editor Tutorial for Excel - How to use the VBE

Цитата
Михаил Лебедев написал:
В строке 16 кода вы берете и копируете значение не из Лист1, а из активного листа книги, из которой запускаете макрос.
- если это мне, то ошибаетесь.
Про переменную согласен, чуть короче.
P.S. А Ваш код не взлетел - ну нет вдруг в открываемом файле .Worksheets("Лист1")...
Изменено: Hugo - 02.10.2020 20:17:32
 
Цитата
Михаил Лебедев написал:
М.б. всё же VBA?
Михаил, а что не так? VBE - редактор (VBEditor)  :)  
Страницы: 1 2 След.
Наверх