Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос "Copy_ROWs_to_EXT_FILE" - Страница 3 - Мир MS Excel

Старая форма входа
  • Страница 3 из 4
  • «
  • 1
  • 2
  • 3
  • 4
  • »
Модератор форума: _Boroda_, китин  
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "Copy_ROWs_to_EXT_FILE" (Копирование строк выбранных ячеек во внешний файл)
Макрос "Copy_ROWs_to_EXT_FILE"
Alex_ST Дата: Среда, 23.04.2014, 14:56 | Сообщение № 41
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Цитата amiko, 23.04.2014 в 14:39, в сообщении № 40
копирует по адресам только построчно, т.е. если выделить 2 строчки с разными адресами, то он скопирует их в один файл,
так и задумывалось именно для того,чтобы не было недоразумений с разными адресами в разных строках.
Именно для этого я при задании адреса и написАл, что выбирать его нужно из Selection(1).Row, т.е. из первой строки выделенного диапазона.
Конечно, не очень сложно было бы и цикл по всем выделенным строкам устроить...
Но, честно говоря, лень. Сейчас вдруг образовался перерыв в завале на работе. Вот я и смог немного отвлечься на любимую головоломку - Excel.
А учиться можно, например, по литературе, лежащей здесь на сайте в Библиотеке
Уокенбах - это Библия для VBA Excel


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
Сообщение
Цитата amiko, 23.04.2014 в 14:39, в сообщении № 40
копирует по адресам только построчно, т.е. если выделить 2 строчки с разными адресами, то он скопирует их в один файл,
так и задумывалось именно для того,чтобы не было недоразумений с разными адресами в разных строках.
Именно для этого я при задании адреса и написАл, что выбирать его нужно из Selection(1).Row, т.е. из первой строки выделенного диапазона.
Конечно, не очень сложно было бы и цикл по всем выделенным строкам устроить...
Но, честно говоря, лень. Сейчас вдруг образовался перерыв в завале на работе. Вот я и смог немного отвлечься на любимую головоломку - Excel.
А учиться можно, например, по литературе, лежащей здесь на сайте в Библиотеке
Уокенбах - это Библия для VBA Excel
Автор - Alex_ST
Дата добавления - 23.04.2014 в 14:56
Alex_ST Дата: Среда, 23.04.2014, 15:12 | Сообщение № 42
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
А попробуйте-ка так:[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
'---------------------------------------------------------------------------------------
' Procedure    : Copy_ROWs_to_EXT_FILES
' Author       : KuklP & Alex_ST
' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
' Topic_URL    : http://www.excelworld.ru/forum/3-176-91092-16-1398251538
' DateTime     : 23.04.14, 15:12
' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
'                 Private Sub Workbook_Open()
'                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
'                 End Sub
'---------------------------------------------------------------------------------------
     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).Row).Value
        sNetDestPath = Range(sNetAddrCol & Selection(i).Row).Value
        On Error Resume Next
        Set wbkDEST = GetObject(sLocDestPath)   ' локальный файл-накопитель
        If Err Then Err.Clear: Set wbkDEST = GetObject(sNetDestPath)   ' сетевой файл-накопитель (если нужно)
        If Err Then MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": GoTo Next_i

        lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        Selection(i).EntireRow.Copy wbkDEST.Sheets(1).Cells(lr + 1, 1)   ' копирование
        wbkDEST.Close (True)   ' закрыть с сохранением
Next_i:       Next i
     With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
     Set wbkDEST = Nothing
End Sub
[/vba]не проверял. Но может быть и заработает. Правда за тормоза не ручаюсь.
Да! И выбирайте только непрерывные диапазоны! Тут только цикл по строкам выделенного диапазона. Циклы по областям я не делал.


С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Среда, 23.04.2014, 15:17
 
Ответить
СообщениеА попробуйте-ка так:[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
'---------------------------------------------------------------------------------------
' Procedure    : Copy_ROWs_to_EXT_FILES
' Author       : KuklP & Alex_ST
' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
' Topic_URL    : http://www.excelworld.ru/forum/3-176-91092-16-1398251538
' DateTime     : 23.04.14, 15:12
' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
'                 Private Sub Workbook_Open()
'                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
'                 End Sub
'---------------------------------------------------------------------------------------
     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).Row).Value
        sNetDestPath = Range(sNetAddrCol & Selection(i).Row).Value
        On Error Resume Next
        Set wbkDEST = GetObject(sLocDestPath)   ' локальный файл-накопитель
        If Err Then Err.Clear: Set wbkDEST = GetObject(sNetDestPath)   ' сетевой файл-накопитель (если нужно)
        If Err Then MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": GoTo Next_i

        lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
        Selection(i).EntireRow.Copy wbkDEST.Sheets(1).Cells(lr + 1, 1)   ' копирование
        wbkDEST.Close (True)   ' закрыть с сохранением
Next_i:       Next i
     With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
     Set wbkDEST = Nothing
End Sub
[/vba]не проверял. Но может быть и заработает. Правда за тормоза не ручаюсь.
Да! И выбирайте только непрерывные диапазоны! Тут только цикл по строкам выделенного диапазона. Циклы по областям я не делал.
Автор - Alex_ST
Дата добавления - 23.04.2014 в 15:12
amiko Дата: Среда, 23.04.2014, 16:00 | Сообщение № 43
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Построчно все работает, диапазон с одинаковыми адресами не работает (копируется только первая строчка), и диапазон с разными адресами тоже не копируются (так же только первая строчка)+ сама таблица становится невидимой.
 
Ответить
СообщениеПострочно все работает, диапазон с одинаковыми адресами не работает (копируется только первая строчка), и диапазон с разными адресами тоже не копируются (так же только первая строчка)+ сама таблица становится невидимой.
Автор - amiko
Дата добавления - 23.04.2014 в 16:00
Alex_ST Дата: Среда, 23.04.2014, 16:48 | Сообщение № 44
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Понял где собака порылась...
В цикле по строкам Selection
При одномерном переборе Selection(i) ячейки перебираются слева-направо, сверху вниз.
А нам нужно сверху вниз. Тогда нужен двумерный перебор (т.е. по любому фиксированному столбцу, например, 1)
Попробуйте так:[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
'---------------------------------------------------------------------------------------
' Procedure    : Copy_ROWs_to_EXT_FILES
' Author       : KuklP & Alex_ST
' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
' Topic_URL    : http://www.excelworld.ru/forum/3-176-91092-16-1398251538
' DateTime     : 23.04.14, 15:12
' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
'                 Private Sub Workbook_Open()
'                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
'                 End Sub
'---------------------------------------------------------------------------------------
    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 MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": 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).EntireRow.Copy wbkDEST.Sheets(1).Cells(lr + 1, 1)   ' копирование
       wbkDEST.Close (True)   ' закрыть с сохранением
Next_i:       Next i
    With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
    Set wbkDEST = Nothing
End Sub
[/vba]


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеПонял где собака порылась...
В цикле по строкам Selection
При одномерном переборе Selection(i) ячейки перебираются слева-направо, сверху вниз.
А нам нужно сверху вниз. Тогда нужен двумерный перебор (т.е. по любому фиксированному столбцу, например, 1)
Попробуйте так:[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
'---------------------------------------------------------------------------------------
' Procedure    : Copy_ROWs_to_EXT_FILES
' Author       : KuklP & Alex_ST
' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
' Topic_URL    : http://www.excelworld.ru/forum/3-176-91092-16-1398251538
' DateTime     : 23.04.14, 15:12
' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
'                 Private Sub Workbook_Open()
'                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
'                 End Sub
'---------------------------------------------------------------------------------------
    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 MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": 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).EntireRow.Copy wbkDEST.Sheets(1).Cells(lr + 1, 1)   ' копирование
       wbkDEST.Close (True)   ' закрыть с сохранением
Next_i:       Next i
    With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
    Set wbkDEST = Nothing
End Sub
[/vba]
Автор - Alex_ST
Дата добавления - 23.04.2014 в 16:48
amiko Дата: Среда, 23.04.2014, 17:08 | Сообщение № 45
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Уже почти пашет как надо:
-Строки с разными уникальными адресами пишутся в разных файлах, но в каждом из них пишется только первая выделенная строка
-Строки с одинаковыми адресами закрывают принудительно файл с макросом и пишут так же только первую выделенную строку
-По одной строке все работает как надо
 
Ответить
СообщениеУже почти пашет как надо:
-Строки с разными уникальными адресами пишутся в разных файлах, но в каждом из них пишется только первая выделенная строка
-Строки с одинаковыми адресами закрывают принудительно файл с макросом и пишут так же только первую выделенную строку
-По одной строке все работает как надо
Автор - amiko
Дата добавления - 23.04.2014 в 17:08
Alex_ST Дата: Среда, 23.04.2014, 17:10 | Сообщение № 46
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Ну, правильно... Не везде поправил выборку на двумерное обращение.
Пробуйте[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
'---------------------------------------------------------------------------------------
' Procedure    : Copy_ROWs_to_EXT_FILES
' Author       : KuklP & Alex_ST
' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
' Topic_URL    : http://www.excelworld.ru/forum/3-176-91092-16-1398251538
' DateTime     : 23.04.14, 15:12
' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
'                 Private Sub Workbook_Open()
'                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
'                 End Sub
'---------------------------------------------------------------------------------------
    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 MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": 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)   ' закрыть с сохранением
Next_i:       Next i
    With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
    Set wbkDEST = Nothing
End Sub
[/vba]


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеНу, правильно... Не везде поправил выборку на двумерное обращение.
Пробуйте[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
'---------------------------------------------------------------------------------------
' Procedure    : Copy_ROWs_to_EXT_FILES
' Author       : KuklP & Alex_ST
' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
' Topic_URL    : http://www.excelworld.ru/forum/3-176-91092-16-1398251538
' DateTime     : 23.04.14, 15:12
' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
'                 Private Sub Workbook_Open()
'                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
'                 End Sub
'---------------------------------------------------------------------------------------
    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 MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": 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)   ' закрыть с сохранением
Next_i:       Next i
    With Application: .EnableEvents = True: .DisplayAlerts = True: .ScreenUpdating = True: End With
    Set wbkDEST = Nothing
End Sub
[/vba]
Автор - Alex_ST
Дата добавления - 23.04.2014 в 17:10
Alex_ST Дата: Среда, 23.04.2014, 17:15 | Сообщение № 47
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Ну всё! Работы под конец дня подвалили.
Больше бездельничать не смогу.
Завтра буду весь день на объекте, а послезавтра - разгребать недоделанное сегодня и то, что завтра подкинут.


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеНу всё! Работы под конец дня подвалили.
Больше бездельничать не смогу.
Завтра буду весь день на объекте, а послезавтра - разгребать недоделанное сегодня и то, что завтра подкинут.
Автор - Alex_ST
Дата добавления - 23.04.2014 в 17:15
amiko Дата: Среда, 23.04.2014, 17:20 | Сообщение № 48
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
))) Развязка близко!
-Строки с разными уникальными адресами пишутся в разных файлах как надо!!!
-Строки с одинаковыми адресами закрывают принудительно файл с макросом и пишут только первую выделенную строку
-По одной строке все работает как надо
Спасибо большущее в любом случае!


Сообщение отредактировал amiko - Среда, 23.04.2014, 17:22
 
Ответить
Сообщение))) Развязка близко!
-Строки с разными уникальными адресами пишутся в разных файлах как надо!!!
-Строки с одинаковыми адресами закрывают принудительно файл с макросом и пишут только первую выделенную строку
-По одной строке все работает как надо
Спасибо большущее в любом случае!
Автор - amiko
Дата добавления - 23.04.2014 в 17:20
Alex_ST Дата: Среда, 23.04.2014, 17:24 | Сообщение № 49
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Цитата amiko, 23.04.2014 в 17:20, в сообщении № 48
-Строки с одинаковыми адресами закрывают принудительно файл с макросом
Чудеса!
Т.е. если строки с одинаковыми адресами получателя идут подряд, то после первого обращения кирдык настаёт? И сам файл Источник даже закрывается?
А если не подряд в один и тот же файл, а по очереди в два?
Ну всё. Разлогиниваюсь.


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
Сообщение
Цитата amiko, 23.04.2014 в 17:20, в сообщении № 48
-Строки с одинаковыми адресами закрывают принудительно файл с макросом
Чудеса!
Т.е. если строки с одинаковыми адресами получателя идут подряд, то после первого обращения кирдык настаёт? И сам файл Источник даже закрывается?
А если не подряд в один и тот же файл, а по очереди в два?
Ну всё. Разлогиниваюсь.
Автор - Alex_ST
Дата добавления - 23.04.2014 в 17:24
amiko Дата: Среда, 23.04.2014, 17:36 | Сообщение № 50
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Настает именно кирдык, и сам источник закрывается, а если одинаковые адреса не подряд, то при первом же повторе происходит тоже самое, но до повтора все прекрасно пишется. Т.е. все уникальные адреса пропишутся как надо, но повторы в последнем варианте не проходят вне зависимости от последовательности строк.
 
Ответить
СообщениеНастает именно кирдык, и сам источник закрывается, а если одинаковые адреса не подряд, то при первом же повторе происходит тоже самое, но до повтора все прекрасно пишется. Т.е. все уникальные адреса пропишутся как надо, но повторы в последнем варианте не проходят вне зависимости от последовательности строк.
Автор - amiko
Дата добавления - 23.04.2014 в 17:36
Alex_ST Дата: Среда, 23.04.2014, 22:35 | Сообщение № 51
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Чтобы не загибался Excel можно попробовать ввести задержку после каждого закрытия файла Получателя в цикле.
Попробуйте вот так:[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
     '---------------------------------------------------------------------------------------
     ' Procedure    : Copy_ROWs_to_EXT_FILES
     ' Author       : KuklP & Alex_ST
     ' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
     ' Topic_URL    : http://www.excelworld.ru/forum/3-176-91117-16-1398258642
     ' DateTime     : 23.04.14, 17:10
     ' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
     ' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
     ' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
     '                 Private Sub Workbook_Open()
     '                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
     '                 End Sub
     '---------------------------------------------------------------------------------------
     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 MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": 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)   ' закрыть с сохранением
         fnDelay (0.5)  ' задержка
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 + Delta
     Do While Timer < Finish: Loop
End Function
[/vba]здесь функция fnDelay, вызываемая после закрытия и сохранения книги, получает в аргументе время задержки 0,5 секунд. Может быть такой задержки и будет достаточно. Если не поможет, попробуйте увеличить задержку, например для начала до 1 секунды.
Завтра я весь день буду в местной командировке. Так что на мою помощь днём не рассчитывайте.
А вечером загляну. Удачи.


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеЧтобы не загибался Excel можно попробовать ввести задержку после каждого закрытия файла Получателя в цикле.
Попробуйте вот так:[vba]
Код
Sub Copy_ROWs_to_EXT_FILES()   ' скопировать строки выделенных ячеек во внешние файлы-накопители
     '---------------------------------------------------------------------------------------
     ' Procedure    : Copy_ROWs_to_EXT_FILES
     ' Author       : KuklP & Alex_ST
     ' Topic_HEADER : Макрос "Copy_ROWs_to_EXT_FILE"
     ' Topic_URL    : http://www.excelworld.ru/forum/3-176-91117-16-1398258642
     ' DateTime     : 23.04.14, 17:10
     ' Purpose      : скопировать строки выделенных ячеек во внешние файлы-накопители
     ' Notes1       : основной и резервный (сетевой) пути к файлам-накопителям прописываются в указанных в коде ячейках копируемых строк листа файла-источника
     ' Notes2       : чтобы после работы макроса файлы-накопители не становились невидимым в окнах Excel (как надстройка или Personal.xls), в их модулях ЭтаКнига нужно прописать:
     '                 Private Sub Workbook_Open()
     '                    If Me.Parent.Caption = Application.Caption Then Windows(Me.Name).Visible = True
     '                 End Sub
     '---------------------------------------------------------------------------------------
     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 MsgBox "Файл-накопитель " & wbkDEST.FullName & " не доступен!": 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)   ' закрыть с сохранением
         fnDelay (0.5)  ' задержка
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 + Delta
     Do While Timer < Finish: Loop
End Function
[/vba]здесь функция fnDelay, вызываемая после закрытия и сохранения книги, получает в аргументе время задержки 0,5 секунд. Может быть такой задержки и будет достаточно. Если не поможет, попробуйте увеличить задержку, например для начала до 1 секунды.
Завтра я весь день буду в местной командировке. Так что на мою помощь днём не рассчитывайте.
А вечером загляну. Удачи.
Автор - Alex_ST
Дата добавления - 23.04.2014 в 22:35
amiko Дата: Четверг, 24.04.2014, 12:17 | Сообщение № 52
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
К сожалению с задержкой все тоже самое, выставлял до 500, и тот же кирдык при повторной записи по одному и тому же адресу накопителя.
 
Ответить
СообщениеК сожалению с задержкой все тоже самое, выставлял до 500, и тот же кирдык при повторной записи по одному и тому же адресу накопителя.
Автор - amiko
Дата добавления - 24.04.2014 в 12:17
Alex_ST Дата: Четверг, 24.04.2014, 20:24 | Сообщение № 53
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Цитата amiko, 24.04.2014 в 12:17, в сообщении № 52
выставлял до 500
500 секунд ждали?!!!
Ну, блин, терпеливый энтузиаст! hands
Ну, тогда я пас. Мысли кончились :(
Может быть кто-нибудь из местных знатоков сможет помочь?
А вообще-то сляпайте-ка Вы тестовый файл в несколько строк данных с прописанными разными и одинаковыми накопителями в корне диска С и выложите сюда. Пусть народ попробует на своих компах. Может быть дело не в процедуре, а в Вашем Офисе/компе?


С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Четверг, 24.04.2014, 20:26
 
Ответить
Сообщение
Цитата amiko, 24.04.2014 в 12:17, в сообщении № 52
выставлял до 500
500 секунд ждали?!!!
Ну, блин, терпеливый энтузиаст! hands
Ну, тогда я пас. Мысли кончились :(
Может быть кто-нибудь из местных знатоков сможет помочь?
А вообще-то сляпайте-ка Вы тестовый файл в несколько строк данных с прописанными разными и одинаковыми накопителями в корне диска С и выложите сюда. Пусть народ попробует на своих компах. Может быть дело не в процедуре, а в Вашем Офисе/компе?
Автор - Alex_ST
Дата добавления - 24.04.2014 в 20:24
amiko Дата: Пятница, 25.04.2014, 00:07 | Сообщение № 54
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
Завтра утром выложу обязательно, а подождать 500 секунд не смог бы даже еслиб хотел, т.к. Все Закрывается при копировании по повторяющимся адресам сразу после запуска. Хотя даже и по разным адресам при копировании такой длинной паузы не было, может там ошибка в синтаксисе задержки? Проще будет положить пример в архиве с накопителями, адреса пропишу сразу чтоб все работало в корне диска с: для удобства.
З.ы. Кстати книгу почти всю прочел, спасибо, действительно вещь, жаль диск не приложен, примеры из текста копируется с огромным количеством ошибок, устаю исправлять.


Сообщение отредактировал amiko - Пятница, 25.04.2014, 00:10
 
Ответить
СообщениеЗавтра утром выложу обязательно, а подождать 500 секунд не смог бы даже еслиб хотел, т.к. Все Закрывается при копировании по повторяющимся адресам сразу после запуска. Хотя даже и по разным адресам при копировании такой длинной паузы не было, может там ошибка в синтаксисе задержки? Проще будет положить пример в архиве с накопителями, адреса пропишу сразу чтоб все работало в корне диска с: для удобства.
З.ы. Кстати книгу почти всю прочел, спасибо, действительно вещь, жаль диск не приложен, примеры из текста копируется с огромным количеством ошибок, устаю исправлять.
Автор - amiko
Дата добавления - 25.04.2014 в 00:07
Alex_ST Дата: Пятница, 25.04.2014, 09:13 | Сообщение № 55
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Позор на мою седую бороду :'(
Вот что значит второпях и не проверяя на ночь глядя процедуры писАть...
Ну вот и получилось, что при "причёсывании" процедуры задержки не все сходу заданные имена переменных заменил на новые, более корректные.
Так должно быть (на этот раз проверил :) ) [vba]
Код
Function fnDelay(Seconds As Single)  ' задержка
      Dim Finish As Single: Finish = Timer + Seconds
      Do While Timer < Finish: Loop
End Function
[/vba]
А вывод сообщения об ошибке блокировал ранее включенный в основной процедуре обработчик ошибок [vba]
Код
On Error Resume Next
[/vba]


С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Пятница, 25.04.2014, 10:42
 
Ответить
СообщениеПозор на мою седую бороду :'(
Вот что значит второпях и не проверяя на ночь глядя процедуры писАть...
Ну вот и получилось, что при "причёсывании" процедуры задержки не все сходу заданные имена переменных заменил на новые, более корректные.
Так должно быть (на этот раз проверил :) ) [vba]
Код
Function fnDelay(Seconds As Single)  ' задержка
      Dim Finish As Single: Finish = Timer + Seconds
      Do While Timer < Finish: Loop
End Function
[/vba]
А вывод сообщения об ошибке блокировал ранее включенный в основной процедуре обработчик ошибок [vba]
Код
On Error Resume Next
[/vba]
Автор - Alex_ST
Дата добавления - 25.04.2014 в 09:13
Alex_ST Дата: Пятница, 25.04.2014, 09:17 | Сообщение № 56
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
А ещё корректнее было бы вообще так написать:[vba]
Код
Function fnDelay(Seconds As Single)  ' задержка
     Dim Finish As Single: Finish = Timer + Seconds
     Do While Timer < Finish: DoEvents: Loop
End Function
[/vba]здесь директива DoEvents разрешит обработку событий во время цикла задержки и его можно будет при необходимости прервать по Ctrl+Break


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеА ещё корректнее было бы вообще так написать:[vba]
Код
Function fnDelay(Seconds As Single)  ' задержка
     Dim Finish As Single: Finish = Timer + Seconds
     Do While Timer < Finish: DoEvents: Loop
End Function
[/vba]здесь директива DoEvents разрешит обработку событий во время цикла задержки и его можно будет при необходимости прервать по Ctrl+Break
Автор - Alex_ST
Дата добавления - 25.04.2014 в 09:17
Alex_ST Дата: Пятница, 25.04.2014, 09:31 | Сообщение № 57
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
А по поводу учебников, так, похоже, что Серж почистил библиотеку от старых файлов и "вместе с грязной водой из ванночки ребёнка выплеснул" :)
Или я просто не смог найти :( Но тогда значит не только я, старожил, но и новички не смогут найти.
Ну, в общем, я слил свою библиотеку на Гугл.Диск поковыряйтесь. Там кроме Уокенбаха ещё много других ценных книжек лежит.


С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Пятница, 25.04.2014, 09:33
 
Ответить
СообщениеА по поводу учебников, так, похоже, что Серж почистил библиотеку от старых файлов и "вместе с грязной водой из ванночки ребёнка выплеснул" :)
Или я просто не смог найти :( Но тогда значит не только я, старожил, но и новички не смогут найти.
Ну, в общем, я слил свою библиотеку на Гугл.Диск поковыряйтесь. Там кроме Уокенбаха ещё много других ценных книжек лежит.
Автор - Alex_ST
Дата добавления - 25.04.2014 в 09:31
amiko Дата: Пятница, 25.04.2014, 11:53 | Сообщение № 58
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
За базу знаний спасибо.
Задержка заработала, но дело оказалось не в ней, при копировании области по повторному адресу debuger указал на эту строку
"lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row"
Подстегнул пример с накопителями и адресами накопителей (1.xls,2.xls,3.xls) на диске С: + сообщение об ошибке.
Попробуйте, может действительно дело в версиях или настройках Excel или VBA.
К сообщению приложен файл: 1631362.rar (79.4 Kb)


Сообщение отредактировал amiko - Пятница, 25.04.2014, 11:57
 
Ответить
СообщениеЗа базу знаний спасибо.
Задержка заработала, но дело оказалось не в ней, при копировании области по повторному адресу debuger указал на эту строку
"lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row"
Подстегнул пример с накопителями и адресами накопителей (1.xls,2.xls,3.xls) на диске С: + сообщение об ошибке.
Попробуйте, может действительно дело в версиях или настройках Excel или VBA.
Автор - amiko
Дата добавления - 25.04.2014 в 11:53
Alex_ST Дата: Пятница, 25.04.2014, 12:25 | Сообщение № 59
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3214
Репутация: 609 ±
Замечаний: 0% ±

2003
Я не могу на работе скачивать файлы с макросами...
1. Какую ошибку выдал? Скиньте скриншот.
2. Если выделить одну строку, то нормально проходит цикл из одного элемента? И не ругается?
3. Попробуйте применить другой метод определения первой свободной строки: снимите комментарий со строки[vba]
Код
     'lr = wbkDEST.Sheets(1).UsedRange.Row + wbkDEST.Sheets(1).UsedRange.Rows.Count - 1
[/vba]и закомментируйте строку [vba]
Код
    lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
[/vba]


С уважением,
Алексей
MS Excel 2003 - the best!!!
 
Ответить
СообщениеЯ не могу на работе скачивать файлы с макросами...
1. Какую ошибку выдал? Скиньте скриншот.
2. Если выделить одну строку, то нормально проходит цикл из одного элемента? И не ругается?
3. Попробуйте применить другой метод определения первой свободной строки: снимите комментарий со строки[vba]
Код
     'lr = wbkDEST.Sheets(1).UsedRange.Row + wbkDEST.Sheets(1).UsedRange.Rows.Count - 1
[/vba]и закомментируйте строку [vba]
Код
    lr = wbkDEST.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
[/vba]
Автор - Alex_ST
Дата добавления - 25.04.2014 в 12:25
amiko Дата: Пятница, 25.04.2014, 12:51 | Сообщение № 60
Группа: Пользователи
Ранг: Новичок
Сообщений: 13
Репутация: 0 ±
Замечаний: 0% ±

Excel 2007
1. Скрин в файле
2. Из одного проходит нормально, и из нескольких разных все проходит нормально даже без задержки.
3. попробовал, опять ошибка но в другой строке с другим оператором.
К сообщению приложен файл: 1962387.docx (54.0 Kb)
 
Ответить
Сообщение1. Скрин в файле
2. Из одного проходит нормально, и из нескольких разных все проходит нормально даже без задержки.
3. попробовал, опять ошибка но в другой строке с другим оператором.
Автор - amiko
Дата добавления - 25.04.2014 в 12:51
Мир MS Excel » Вопросы и решения » Готовые решения » Макрос "Copy_ROWs_to_EXT_FILE" (Копирование строк выбранных ячеек во внешний файл)
  • Страница 3 из 4
  • «
  • 1
  • 2
  • 3
  • 4
  • »
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!