Приветствую всех форумчан. Не могу сам разобраться с причиной того что творится в моем макросе. Суть задачи вроде простая, скопировать лист полностью и вставить в другие книги одной папки закрытые с паролем информацию с листа "Цены" диапазон A1:J1000 на лист с аналогичным названием. У меня вместо этого создаются новые файлы. Подскажите пожалуйста что я не так делаю. Благодарю!
Приветствую всех форумчан. Не могу сам разобраться с причиной того что творится в моем макросе. Суть задачи вроде простая, скопировать лист полностью и вставить в другие книги одной папки закрытые с паролем информацию с листа "Цены" диапазон A1:J1000 на лист с аналогичным названием. У меня вместо этого создаются новые файлы. Подскажите пожалуйста что я не так делаю. Благодарю!ASM_0408
Так что Вы копируете-то? Лист полностью или диапазон? И запароленная папка — это фиговое решение. Проще и надёжнее скрывать листы до xlVeryHidden.
Так что Вы копируете-то? Лист полностью или диапазон? И запароленная папка — это фиговое решение. Проще и надёжнее скрывать листы до xlVeryHidden.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
Сообщение отредактировал StoTisteg - Среда, 18.04.2018, 17:00
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
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]
Или же [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
А подскажите пожалуйста как диапазоном копировать и вставлять при условии что нужно заменить во всех книгах одной папки. Почему не лист на листах имеются расчеты отличные друг от друга а этот диапазон свободен во всех книгах.
А подскажите пожалуйста как диапазоном копировать и вставлять при условии что нужно заменить во всех книгах одной папки. Почему не лист на листах имеются расчеты отличные друг от друга а этот диапазон свободен во всех книгах.ASM_0408
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 'возвращаем ранее отключенное обновление экрана
Во-первых, я не вижу, где Вы открываете книгу sFiles. Затем - не Workbooks(sFolder & sFiles), а Workbooks(sFiles). Открывать нужно сначала конечную, потом начальную. Не вижу заголовка If'а.
Во-первых, я не вижу, где Вы открываете книгу sFiles. Затем - не Workbooks(sFolder & sFiles), а Workbooks(sFiles). Открывать нужно сначала конечную, потом начальную. Не вижу заголовка If'а.StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
ASM_0408, то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто. Какой смысл в цикле Do, если внутри него в принципе не меняется проверяемый в заголовке параметр?
ASM_0408, то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто. Какой смысл в цикле Do, если внутри него в принципе не меняется проверяемый в заголовке параметр?StoTisteg
Интуитивно понятный код - это когда интуитивно понятно, что это код.
то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто.
Я изначально приложил файл и написал что он не работает так как я бы хотел. Цикл Do Loop работает для перебора файлов папке, если есть другие варианты я приму и проработаю. А сейчас проработав код дошел до выделения и копирования, но вот вставка и закрытие не срабатывают подскажите пожалуйста в чем ошибка. Файл приложен.
то ли это огрызок кода, то ли какое-то странное неработоспособное в принципе нечто.
Я изначально приложил файл и написал что он не работает так как я бы хотел. Цикл Do Loop работает для перебора файлов папке, если есть другие варианты я приму и проработаю. А сейчас проработав код дошел до выделения и копирования, но вот вставка и закрытие не срабатывают подскажите пожалуйста в чем ошибка. Файл приложен.ASM_0408
Он не будет перебирать файлы в папке. Перебор делаем так. [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]
Он не будет перебирать файлы в папке. Перебор делаем так. [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