Протестировал на своём компе. Создал в корне диска С 3 файла: test1.xls test2.xls test3.xls В файле-источнике прописал их адреса в столбце А, а в столбце С - разные данные чтобы видеть, какие строки копируются C:\test1.xls 1 C:\test1.xls 2 C:\test1.xls 3 C:\test2.xls 1 C:\test2.xls 2 C:\test2.xls 3 C:\test3.xls 1 C:\test3.xls 2 C:\test3.xls 3 Чуть подправил код чтобы источник не "прятался" Вот так[vba]
Код
Sub Copy_ROWs_to_EXT_FILES() ' скопировать строки выделенных ячеек во внешние файлы-накопители If Not TypeName(Selection) = "Range" Then Exit Sub Dim lr&, wbkDEST As Workbook, i% Const sLocAddrCol$ = "A" ' столбец, в ячейках которого прописан локальный (основной) путь к файлу-накопителю Const sNetAddrCol$ = "B" ' столбец, в ячейках которого прописан сетевой (резервный) путь к файлу-накопителю Dim sLocDestPath$ ' локальный (основной) путь к файлу-накопителю Dim sNetDestPath$ ' сетевой (резервный) путь к файлу-накопителю With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With For i = 1 To Selection.Rows.Count sLocDestPath = Range(sLocAddrCol & Selection(i, 1).Row).Value sNetDestPath = Range(sNetAddrCol & Selection(i, 1).Row).Value On Error Resume Next Set wbkDEST = GetObject(sLocDestPath) ' локальный файл-накопитель If Err Then Err.Clear: Set wbkDEST = GetObject(sNetDestPath) ' сетевой файл-накопитель (если нужно) If Err Then Err.Clear: MsgBox "Файл-накопитель не доступен!": GoTo Next_i
lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'lr = wbkDEST.Sheets(1).UsedRange.Row + wbkDEST.Sheets(1).UsedRange.Rows.Count - 1 Selection(i, 1).EntireRow.Copy wbkDEST.Sheets(1).Cells(lr + 1, 1) ' копирование wbkDEST.Close (True) ' закрыть с сохранением Windows(ThisWorkbook.Name).Visible = True fnDelay (3) ' задержка Next_i: Next i With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With Set wbkDEST = Nothing End Sub
Function fnDelay(Seconds As Single) ' задержка Dim Finish As Single: Finish = Timer + Seconds Do While Timer < Finish: DoEvents: Loop End Function
[/vba]у меня копирует только первую и последнюю строки из диапазона с одинаковыми адресами получателя. При этом в пошаговом режиме всё проходит нормально. А в автомате даже с задержкой 3 секунды - нет
Протестировал на своём компе. Создал в корне диска С 3 файла: test1.xls test2.xls test3.xls В файле-источнике прописал их адреса в столбце А, а в столбце С - разные данные чтобы видеть, какие строки копируются C:\test1.xls 1 C:\test1.xls 2 C:\test1.xls 3 C:\test2.xls 1 C:\test2.xls 2 C:\test2.xls 3 C:\test3.xls 1 C:\test3.xls 2 C:\test3.xls 3 Чуть подправил код чтобы источник не "прятался" Вот так[vba]
Код
Sub Copy_ROWs_to_EXT_FILES() ' скопировать строки выделенных ячеек во внешние файлы-накопители If Not TypeName(Selection) = "Range" Then Exit Sub Dim lr&, wbkDEST As Workbook, i% Const sLocAddrCol$ = "A" ' столбец, в ячейках которого прописан локальный (основной) путь к файлу-накопителю Const sNetAddrCol$ = "B" ' столбец, в ячейках которого прописан сетевой (резервный) путь к файлу-накопителю Dim sLocDestPath$ ' локальный (основной) путь к файлу-накопителю Dim sNetDestPath$ ' сетевой (резервный) путь к файлу-накопителю With Application: .ScreenUpdating = False: .DisplayAlerts = False: .EnableEvents = False: End With For i = 1 To Selection.Rows.Count sLocDestPath = Range(sLocAddrCol & Selection(i, 1).Row).Value sNetDestPath = Range(sNetAddrCol & Selection(i, 1).Row).Value On Error Resume Next Set wbkDEST = GetObject(sLocDestPath) ' локальный файл-накопитель If Err Then Err.Clear: Set wbkDEST = GetObject(sNetDestPath) ' сетевой файл-накопитель (если нужно) If Err Then Err.Clear: MsgBox "Файл-накопитель не доступен!": GoTo Next_i
lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'lr = wbkDEST.Sheets(1).UsedRange.Row + wbkDEST.Sheets(1).UsedRange.Rows.Count - 1 Selection(i, 1).EntireRow.Copy wbkDEST.Sheets(1).Cells(lr + 1, 1) ' копирование wbkDEST.Close (True) ' закрыть с сохранением Windows(ThisWorkbook.Name).Visible = True fnDelay (3) ' задержка Next_i: Next i With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With Set wbkDEST = Nothing End Sub
Function fnDelay(Seconds As Single) ' задержка Dim Finish As Single: Finish = Timer + Seconds Do While Timer < Finish: DoEvents: Loop End Function
[/vba]у меня копирует только первую и последнюю строки из диапазона с одинаковыми адресами получателя. При этом в пошаговом режиме всё проходит нормально. А в автомате даже с задержкой 3 секунды - нет Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Пятница, 25.04.2014, 13:09
Дошло до меня где собака порылась, в моем случае повторного копирования не происходит, т.к. тестирую не более 2 одинаковых адресов, а в вашем случае, первый и последний из-за того, что копирует он просто через строку. Создайте C:\test1.xls 1 C:\test1.xls 2 C:\test1.xls 3 C:\test1.xls 4 C:\test1.xls 5 C:\test2.xls 1 C:\test2.xls 2 C:\test2.xls 3 C:\test2.xls 4 C:\test2.xls 5 C:\test3.xls 1 C:\test3.xls 2 C:\test3.xls 3 C:\test3.xls 4 C:\test3.xls 5 и у вас результат будет из 3 записей в каждый файл (1,3,5) и задержка никакого смысла в себе не несет.
Дошло до меня где собака порылась, в моем случае повторного копирования не происходит, т.к. тестирую не более 2 одинаковых адресов, а в вашем случае, первый и последний из-за того, что копирует он просто через строку. Создайте C:\test1.xls 1 C:\test1.xls 2 C:\test1.xls 3 C:\test1.xls 4 C:\test1.xls 5 C:\test2.xls 1 C:\test2.xls 2 C:\test2.xls 3 C:\test2.xls 4 C:\test2.xls 5 C:\test3.xls 1 C:\test3.xls 2 C:\test3.xls 3 C:\test3.xls 4 C:\test3.xls 5 и у вас результат будет из 3 записей в каждый файл (1,3,5) и задержка никакого смысла в себе не несет.amiko
Сообщение отредактировал amiko - Пятница, 25.04.2014, 13:28
Андрей, привет. Моя фантазия иссякла. И я, вообще-то, никогда не возражал против получения советов от друзей. Да и тема-то вообще-то не моя, а Сергея KuklP(что-то он давно не появлялся, к стати). Это его коды я полировал.
Андрей, привет. Моя фантазия иссякла. И я, вообще-то, никогда не возражал против получения советов от друзей. Да и тема-то вообще-то не моя, а Сергея KuklP(что-то он давно не появлялся, к стати). Это его коды я полировал.Alex_ST
В данной теме к готовым решениям относятся ДВА первых поста. Все остальное - флуд. Я уже писал - нечего в готовых решениях обсуждать частные вопросы. Но тебе, похоже, нравится.
В данной теме к готовым решениям относятся ДВА первых поста. Все остальное - флуд. Я уже писал - нечего в готовых решениях обсуждать частные вопросы. Но тебе, похоже, нравится. RAN
Alex_ST, добрый день Помогите пожалуйста, в файле, в модуле книги прописываю обработку события Private Sub, выдаёт ошибку run-time error 424, жму debug, выдаёт подчеркнутое if me.parent.caption=application.caption then. Что делать? Файл невидим.
Alex_ST, добрый день Помогите пожалуйста, в файле, в модуле книги прописываю обработку события Private Sub, выдаёт ошибку run-time error 424, жму debug, выдаёт подчеркнутое if me.parent.caption=application.caption then. Что делать? Файл невидим.John2150
1. На всякий случай проверьте, самую ли последнюю версию макроса Вы используете? Это должен быть файл из поста №7 2. Попробуйте в модуле книги прописать в процедуру Private Sub Workbook_Open проверку [vba]
Код
Private Sub Workbook_Open() Debug.Print Me.Parent.Caption Debug.Print Application.Caption If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True End Sub
[/vba] и, выполняя её по шагам (по F8), посмотреть результат в окне "Immediate" (Crtl+G) Если оба объекта назначены (а ошибка run-time error 424 говорит, что объект не назначен), то в окошко должен быть сначала выведен результат типа
Цитата
Microsoft Excel - Copy_ROWs_to_EXT_FILE.xls Microsoft Excel - Copy_ROWs_to_EXT_FILE.xls
, а потом - нормально и без ошибок пройти вычисление условия. Как могут быть не назначены объекты приложения Excel (на него указывает Me.Parent в модуле книги) и Application (это тоже Excel), я не представляю
1. На всякий случай проверьте, самую ли последнюю версию макроса Вы используете? Это должен быть файл из поста №7 2. Попробуйте в модуле книги прописать в процедуру Private Sub Workbook_Open проверку [vba]
Код
Private Sub Workbook_Open() Debug.Print Me.Parent.Caption Debug.Print Application.Caption If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True End Sub
[/vba] и, выполняя её по шагам (по F8), посмотреть результат в окне "Immediate" (Crtl+G) Если оба объекта назначены (а ошибка run-time error 424 говорит, что объект не назначен), то в окошко должен быть сначала выведен результат типа
Цитата
Microsoft Excel - Copy_ROWs_to_EXT_FILE.xls Microsoft Excel - Copy_ROWs_to_EXT_FILE.xls
, а потом - нормально и без ошибок пройти вычисление условия. Как могут быть не назначены объекты приложения Excel (на него указывает Me.Parent в модуле книги) и Application (это тоже Excel), я не представляю Alex_ST
С уважением, Алексей MS Excel 2003 - the best!!!
Сообщение отредактировал Alex_ST - Четверг, 12.08.2021, 08:22