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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование заданного листа в другую книгу - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование заданного листа в другую книгу (Макросы/Sub)
Копирование заданного листа в другую книгу
ASM_0408 Дата: Среда, 18.04.2018, 16:23 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
Приветствую всех форумчан. Не могу сам разобраться с причиной того что творится в моем макросе. Суть задачи вроде простая, скопировать лист полностью и вставить в другие книги одной папки закрытые с паролем информацию с листа "Цены" диапазон A1:J1000 на лист с аналогичным названием. У меня вместо этого создаются новые файлы. Подскажите пожалуйста что я не так делаю.
Благодарю!
К сообщению приложен файл: 12.xlsm (90.4 Kb)
 
Ответить
СообщениеПриветствую всех форумчан. Не могу сам разобраться с причиной того что творится в моем макросе. Суть задачи вроде простая, скопировать лист полностью и вставить в другие книги одной папки закрытые с паролем информацию с листа "Цены" диапазон A1:J1000 на лист с аналогичным названием. У меня вместо этого создаются новые файлы. Подскажите пожалуйста что я не так делаю.
Благодарю!

Автор - ASM_0408
Дата добавления - 18.04.2018 в 16:23
StoTisteg Дата: Среда, 18.04.2018, 16:57 | Сообщение № 2
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Так что Вы копируете-то? Лист полностью или диапазон? И запароленная папка — это фиговое решение. Проще и надёжнее скрывать листы до xlVeryHidden.


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Среда, 18.04.2018, 17:00
 
Ответить
СообщениеТак что Вы копируете-то? Лист полностью или диапазон? И запароленная папка — это фиговое решение. Проще и надёжнее скрывать листы до xlVeryHidden.

Автор - StoTisteg
Дата добавления - 18.04.2018 в 16:57
ASM_0408 Дата: Среда, 18.04.2018, 17:01 | Сообщение № 3
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
Так что Вы копируете-то? Лист полностью или диапазон?

Пытался лист скопировать но лучше думаю будет диапазоном все таки у меня ни так не так не получилось.
 
Ответить
Сообщение
Так что Вы копируете-то? Лист полностью или диапазон?

Пытался лист скопировать но лучше думаю будет диапазоном все таки у меня ни так не так не получилось.

Автор - ASM_0408
Дата добавления - 18.04.2018 в 17:01
StoTisteg Дата: Среда, 18.04.2018, 17:07 | Сообщение № 4
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Лист копировать проще:
[vba]
Код

   Err.Clear
   On Error Resume Next
   Cells.Copy Destination:=Workbooks("ИмяЦелевойКниги").Worksheets(ActiveSheet.Name).Cells
   Msgbox Prompt:="В книге ИмяЦелевойКниги нет листа " & ActiveSheet.Name
[/vba]


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеЛист копировать проще:
[vba]
Код

   Err.Clear
   On Error Resume Next
   Cells.Copy Destination:=Workbooks("ИмяЦелевойКниги").Worksheets(ActiveSheet.Name).Cells
   Msgbox Prompt:="В книге ИмяЦелевойКниги нет листа " & ActiveSheet.Name
[/vba]

Автор - StoTisteg
Дата добавления - 18.04.2018 в 17:07
StoTisteg Дата: Среда, 18.04.2018, 17:17 | Сообщение № 5
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Или же
[vba]
Код

Dim Ws As Worksheet

Set Ws=ActiveSheet
With Workbooks("ИмяЦелевойКниги")
    Err.Clear
    On Error Resume Next
    .Worksheets.Add After:=.Worksheets(Sheets.Count)
    If Err.Number=0 Then Activesheet.Name=Ws.Name
    Ws.Parent.Activate
    Cells.Copy Destination:=.Worksheets(ActiveSheet.Name).Cells
End With
[/vba]


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Среда, 18.04.2018, 17:19
 
Ответить
СообщениеИли же
[vba]
Код

Dim Ws As Worksheet

Set Ws=ActiveSheet
With Workbooks("ИмяЦелевойКниги")
    Err.Clear
    On Error Resume Next
    .Worksheets.Add After:=.Worksheets(Sheets.Count)
    If Err.Number=0 Then Activesheet.Name=Ws.Name
    Ws.Parent.Activate
    Cells.Copy Destination:=.Worksheets(ActiveSheet.Name).Cells
End With
[/vba]

Автор - StoTisteg
Дата добавления - 18.04.2018 в 17:17
ASM_0408 Дата: Среда, 18.04.2018, 17:22 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
А подскажите пожалуйста как диапазоном копировать и вставлять при условии что нужно заменить во всех книгах одной папки. Почему не лист на листах имеются расчеты отличные друг от друга а этот диапазон свободен во всех книгах.
 
Ответить
СообщениеА подскажите пожалуйста как диапазоном копировать и вставлять при условии что нужно заменить во всех книгах одной папки. Почему не лист на листах имеются расчеты отличные друг от друга а этот диапазон свободен во всех книгах.

Автор - ASM_0408
Дата добавления - 18.04.2018 в 17:22
StoTisteg Дата: Среда, 18.04.2018, 17:33 | Сообщение № 7
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код

Range(Cells(1,1),Cells(1000,10)).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
[/vba]


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Среда, 18.04.2018, 17:34
 
Ответить
Сообщение[vba]
Код

Range(Cells(1,1),Cells(1000,10)).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
[/vba]

Автор - StoTisteg
Дата добавления - 18.04.2018 в 17:33
ASM_0408 Дата: Среда, 18.04.2018, 17:42 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
[vba]
Код
Sub Копирование_справочника()
Dim sFolder As String, sFiles As String
Dim Исходная As Workbook
Dim Конечная As Workbook       'Ввод переменной MyWorkbook типа "книга"
Application.ScreenUpdating = False
Set Исходная = Workbooks.Open("Z:\Экономический отдел\12.xlsm")  'Открываем исходную книгу
'диалог запроса выбора папки с файлами
    
        sFolder = "Z:\Экономический отдел\Шаблоны расчетов НЕ ТРОГАТЬ!!!"

    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
   
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
    
   Dim Ws As Worksheet

Set Ws = ActiveSheet
With Workbooks(sFolder & sFiles)
    Err.Clear
    On Error Resume Next
    .Worksheets.Add After:=.Worksheets(Sheets.Count)
    If Err.Number = 0 Then ActiveSheet.Name = Ws.Name
    Ws.Parent.Activate
    Range(Cells(1,1),Cells(1000,10).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
End With
   
    
    Workbooks.Application.DisplayAlerts = False
    Конечная.Save
    Исходная.Close
    Конечная.Close
                'Закрываем книгу с сохранением изменений
        sFiles = Dir
   Else
     MsgBox (sFiles + " уже открыт! Пожалуйста закройте!")
   End If

    Loop
    'возвращаем ранее отключенное обновление экрана
     
    Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
Сообщение[vba]
Код
Sub Копирование_справочника()
Dim sFolder As String, sFiles As String
Dim Исходная As Workbook
Dim Конечная As Workbook       'Ввод переменной MyWorkbook типа "книга"
Application.ScreenUpdating = False
Set Исходная = Workbooks.Open("Z:\Экономический отдел\12.xlsm")  'Открываем исходную книгу
'диалог запроса выбора папки с файлами
    
        sFolder = "Z:\Экономический отдел\Шаблоны расчетов НЕ ТРОГАТЬ!!!"

    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'отключаем обновление экрана, чтобы наши действия не мелькали
   
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
    
   Dim Ws As Worksheet

Set Ws = ActiveSheet
With Workbooks(sFolder & sFiles)
    Err.Clear
    On Error Resume Next
    .Worksheets.Add After:=.Worksheets(Sheets.Count)
    If Err.Number = 0 Then ActiveSheet.Name = Ws.Name
    Ws.Parent.Activate
    Range(Cells(1,1),Cells(1000,10).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
End With
   
    
    Workbooks.Application.DisplayAlerts = False
    Конечная.Save
    Исходная.Close
    Конечная.Close
                'Закрываем книгу с сохранением изменений
        sFiles = Dir
   Else
     MsgBox (sFiles + " уже открыт! Пожалуйста закройте!")
   End If

    Loop
    'возвращаем ранее отключенное обновление экрана
     
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - ASM_0408
Дата добавления - 18.04.2018 в 17:42
ASM_0408 Дата: Среда, 18.04.2018, 17:44 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
Посмотрите я правильно внес исправления листа на диапазон у меня ругается на синтаксис.
 
Ответить
СообщениеПосмотрите я правильно внес исправления листа на диапазон у меня ругается на синтаксис.

Автор - ASM_0408
Дата добавления - 18.04.2018 в 17:44
StoTisteg Дата: Среда, 18.04.2018, 17:47 | Сообщение № 10
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
На какую строку ругается-то?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеНа какую строку ругается-то?

Автор - StoTisteg
Дата добавления - 18.04.2018 в 17:47
ASM_0408 Дата: Среда, 18.04.2018, 17:50 | Сообщение № 11
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
[vba]
Код
Range(Cells(1,1),Cells(1000,10).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
[/vba]
вот на эту
 
Ответить
Сообщение[vba]
Код
Range(Cells(1,1),Cells(1000,10).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
[/vba]
вот на эту

Автор - ASM_0408
Дата добавления - 18.04.2018 в 17:50
ASM_0408 Дата: Среда, 18.04.2018, 17:51 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
Пишет syntax error
 
Ответить
СообщениеПишет syntax error

Автор - ASM_0408
Дата добавления - 18.04.2018 в 17:51
StoTisteg Дата: Среда, 18.04.2018, 17:57 | Сообщение № 13
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Во-первых, я не вижу, где Вы открываете книгу sFiles.
Затем - не Workbooks(sFolder & sFiles), а Workbooks(sFiles).
Открывать нужно сначала конечную, потом начальную.
Не вижу заголовка If'а.


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеВо-первых, я не вижу, где Вы открываете книгу sFiles.
Затем - не Workbooks(sFolder & sFiles), а Workbooks(sFiles).
Открывать нужно сначала конечную, потом начальную.
Не вижу заголовка If'а.

Автор - StoTisteg
Дата добавления - 18.04.2018 в 17:57
StoTisteg Дата: Среда, 18.04.2018, 17:58 | Сообщение № 14
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Пишет syntax error

И? Какую строку красит?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
Сообщение
Пишет syntax error

И? Какую строку красит?

Автор - StoTisteg
Дата добавления - 18.04.2018 в 17:58
ASM_0408 Дата: Среда, 18.04.2018, 18:03 | Сообщение № 15
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
И? Какую строку красит?

Желтым название макроса, синим всю эту строку[vba]
Код
Range(Cells(1,1),Cells(1000,10).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
[/vba]
 
Ответить
Сообщение
И? Какую строку красит?

Желтым название макроса, синим всю эту строку[vba]
Код
Range(Cells(1,1),Cells(1000,10).Copy Destination:=.Worksheets(ActiveSheet.Name).Cells(1,1)
[/vba]

Автор - ASM_0408
Дата добавления - 18.04.2018 в 18:03
RAN Дата: Среда, 18.04.2018, 18:17 | Сообщение № 16
Группа: Друзья
Ранг: Экселист
Сообщений: 5660
Репутация: 1163 ±
Замечаний: 0% ±

2010
[vba]
Код
,10))
[/vba]


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение[vba]
Код
,10))
[/vba]

Автор - RAN
Дата добавления - 18.04.2018 в 18:17
StoTisteg Дата: Четверг, 19.04.2018, 10:20 | Сообщение № 17
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
ASM_0408, то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто. Какой смысл в цикле Do, если внутри него в принципе не меняется проверяемый в заголовке параметр?


Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеASM_0408, то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто. Какой смысл в цикле Do, если внутри него в принципе не меняется проверяемый в заголовке параметр?

Автор - StoTisteg
Дата добавления - 19.04.2018 в 10:20
ASM_0408 Дата: Четверг, 19.04.2018, 12:50 | Сообщение № 18
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 239
Репутация: 0 ±
Замечаний: 0% ±

Excel 2021
то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто.

Я изначально приложил файл и написал что он не работает так как я бы хотел.
Цикл Do Loop работает для перебора файлов папке, если есть другие варианты я приму и проработаю.
А сейчас проработав код дошел до выделения и копирования, но вот вставка и закрытие не срабатывают подскажите пожалуйста в чем ошибка. Файл приложен.
К сообщению приложен файл: 2119070.xlsm (93.3 Kb)
 
Ответить
Сообщение
то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто.

Я изначально приложил файл и написал что он не работает так как я бы хотел.
Цикл Do Loop работает для перебора файлов папке, если есть другие варианты я приму и проработаю.
А сейчас проработав код дошел до выделения и копирования, но вот вставка и закрытие не срабатывают подскажите пожалуйста в чем ошибка. Файл приложен.

Автор - ASM_0408
Дата добавления - 19.04.2018 в 12:50
StoTisteg Дата: Четверг, 19.04.2018, 13:11 | Сообщение № 19
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Он не будет перебирать файлы в папке. Перебор делаем так.
[vba]
Код

Sub Перебор

    Dim sfiles as collection
    Dim fil as Variant
    
    Set sfiles=FilenamesCollection("Z:\Экономический отдел\Шаблоны расчетов НЕ ТРОГАТЬ!!!","*.xls*",1)
    For Each fil In sfiles
         'Здесь операции с файлом
    next fil

End Sub

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", Optional ByVal SearchDeep As Long = 999) As Collection

    Dim FSO As Object

    Set FilenamesCollection = New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
    Set FSO = Nothing
    
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    
    Dim curfold, fil, sfol
    
    On Error Resume Next
    Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1
        If SearchDeep Then
            For Each sfol In curfold.SubFolders
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing
        Set curfold = Nothing
    End If
End Function

[/vba]


Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Четверг, 19.04.2018, 13:13
 
Ответить
СообщениеОн не будет перебирать файлы в папке. Перебор делаем так.
[vba]
Код

Sub Перебор

    Dim sfiles as collection
    Dim fil as Variant
    
    Set sfiles=FilenamesCollection("Z:\Экономический отдел\Шаблоны расчетов НЕ ТРОГАТЬ!!!","*.xls*",1)
    For Each fil In sfiles
         'Здесь операции с файлом
    next fil

End Sub

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", Optional ByVal SearchDeep As Long = 999) As Collection

    Dim FSO As Object

    Set FilenamesCollection = New Collection
    Set FSO = CreateObject("Scripting.FileSystemObject")
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep
    Set FSO = Nothing
    
End Function

Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    
    Dim curfold, fil, sfol
    
    On Error Resume Next
    Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then
        For Each fil In curfold.Files
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1
        If SearchDeep Then
            For Each sfol In curfold.SubFolders
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing
        Set curfold = Nothing
    End If
End Function

[/vba]

Автор - StoTisteg
Дата добавления - 19.04.2018 в 13:11
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование заданного листа в другую книгу (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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