Помогите с макросом, нужно чтобы макрос: кнопка макроса должна быть в "Книга 1" Файл "Книга 1" и "Архив" находятся в разных папках, соответственно нужен вызов проводника из "Книга 1" чтобы я мог выбрать нужный файл для архивации.
1. из "Книга 1" переносил листы в "Архив", поместить в конец книги. 2. условие переноса из "Книга 1" - цвет вкладки Color = 10498160. 3. удалить перенесенные листы из "Книга 1" 4. первые 6 листов в "Книга 1" удалять нельзя, надо их как-то закрепить в том плане что они не подлежат ни переносу, ни удалению
Заранее благодарю всех за помощь!
Добрый день, Уважаемые форумчане!
Помогите с макросом, нужно чтобы макрос: кнопка макроса должна быть в "Книга 1" Файл "Книга 1" и "Архив" находятся в разных папках, соответственно нужен вызов проводника из "Книга 1" чтобы я мог выбрать нужный файл для архивации.
1. из "Книга 1" переносил листы в "Архив", поместить в конец книги. 2. условие переноса из "Книга 1" - цвет вкладки Color = 10498160. 3. удалить перенесенные листы из "Книга 1" 4. первые 6 листов в "Книга 1" удалять нельзя, надо их как-то закрепить в том плане что они не подлежат ни переносу, ни удалению
Павел_леваП, вот у меня есть макрос вызова проводника
[vba]
Код
Sub Архивация () Set active_sheet = ActiveSheet Dim active_sheet_name As String active_sheet_name = ActiveSheet.Name
Dim filePath As String filePath = getFilePath
If filePath = "" Then Exit Sub End If
Set storage = GetWorkbook(filePath) ' ' ' здесь надо перенос листов ' ' ' exeption = MsgBox("Проверьте Архив", 48, "Проверьте Архив")
End Sub
Function getFilePath(Optional ByVal Title As String = "Выберите файл для архивации", _ Optional ByVal InitialPath As String = "D:\ _ Optional ByVal FilterDescription As String = "Книги Excel", _ Optional ByVal FilterExtention As String = "*.xls*") As String On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath .Filters.Clear: .Filters.Add FilterDescription, FilterExtention If .Show <> -1 Then Exit Function getFilePath = .SelectedItems(1): PS = Application.PathSeparator End With End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then Set wbReturn = Workbooks.Open(Filename:=sFullName, ReadOnly:=False, Password:="000000") End If On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
[/vba]
помогите составить макрос на перенос листов из книги в книгу с условием цвет переносимой вкладки (листа) Color = 10498160
Павел_леваП, вот у меня есть макрос вызова проводника
[vba]
Код
Sub Архивация () Set active_sheet = ActiveSheet Dim active_sheet_name As String active_sheet_name = ActiveSheet.Name
Dim filePath As String filePath = getFilePath
If filePath = "" Then Exit Sub End If
Set storage = GetWorkbook(filePath) ' ' ' здесь надо перенос листов ' ' ' exeption = MsgBox("Проверьте Архив", 48, "Проверьте Архив")
End Sub
Function getFilePath(Optional ByVal Title As String = "Выберите файл для архивации", _ Optional ByVal InitialPath As String = "D:\ _ Optional ByVal FilterDescription As String = "Книги Excel", _ Optional ByVal FilterExtention As String = "*.xls*") As String On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath .Filters.Clear: .Filters.Add FilterDescription, FilterExtention If .Show <> -1 Then Exit Function getFilePath = .SelectedItems(1): PS = Application.PathSeparator End With End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then Set wbReturn = Workbooks.Open(Filename:=sFullName, ReadOnly:=False, Password:="000000") End If On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
[/vba]
помогите составить макрос на перенос листов из книги в книгу с условием цвет переносимой вкладки (листа) Color = 10498160Павел_леваП
Сообщение отредактировал Павел_леваП - Вторник, 08.08.2017, 15:28
Павел_леваП, нашел макрос переноса листов начиная со 2-го листа как поменять на условие цвет переносимой вкладки (листа) Color = 10498160 [vba]
Код
Sub Mover3() Dim BkName As String Dim NumSht As Integer Dim BegSht As Integer
'Начинается со второго листа - заменить на Порядковый номер стартового листа BegSht = 7 'Moves two sheets - replace with number of sheets to move. NumSht = 10 BkName = ActiveWorkbook.Name
For x = 1 To NumSht 'Moves second sheet in source to front of designated workbook. Workbooks(BkName).Sheets(BegSht).Move _ Before:=Workbooks("Архив.xls").Sheets(1) 'In each loop, the next sheet in line becomes indexed as number 2. 'Replace Test.xls with the full name of the target workbook you want. Next End Sub
[/vba]
Павел_леваП, нашел макрос переноса листов начиная со 2-го листа как поменять на условие цвет переносимой вкладки (листа) Color = 10498160 [vba]
Код
Sub Mover3() Dim BkName As String Dim NumSht As Integer Dim BegSht As Integer
'Начинается со второго листа - заменить на Порядковый номер стартового листа BegSht = 7 'Moves two sheets - replace with number of sheets to move. NumSht = 10 BkName = ActiveWorkbook.Name
For x = 1 To NumSht 'Moves second sheet in source to front of designated workbook. Workbooks(BkName).Sheets(BegSht).Move _ Before:=Workbooks("Архив.xls").Sheets(1) 'In each loop, the next sheet in line becomes indexed as number 2. 'Replace Test.xls with the full name of the target workbook you want. Next End Sub
For i = 7 To Sheets.Count If ActiveWorkbook.Sheets(i).Tab.Color = 10498160 Then Sheets(i).Move Before:=Workbooks("Архив.xls").Sheets(1) End If
End Sub
Function getFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _ Optional ByVal InitialPath As String = "L:\", _ Optional ByVal FilterDescription As String = "Книги Excel", _ Optional ByVal FilterExtention As String = "*.xls*") As String On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath .Filters.Clear: .Filters.Add FilterDescription, FilterExtention If .Show <> -1 Then Exit Function getFilePath = .SelectedItems(1): PS = Application.PathSeparator End With End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then Set wbReturn = Workbooks.Open(Filename:=sFullName, ReadOnly:=False, Password:="456951") End If On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
[/vba]
не работает. читаю я нормально. Подскажите лучше код, я же написал что я не программист.
RAN, [vba]
Код
Sub архив()
Dim filePath As String filePath = getFilePath
If filePath = "" Then Exit Sub End If
Set storage = GetWorkbook(filePath)
For i = 7 To Sheets.Count If ActiveWorkbook.Sheets(i).Tab.Color = 10498160 Then Sheets(i).Move Before:=Workbooks("Архив.xls").Sheets(1) End If
End Sub
Function getFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _ Optional ByVal InitialPath As String = "L:\", _ Optional ByVal FilterDescription As String = "Книги Excel", _ Optional ByVal FilterExtention As String = "*.xls*") As String On Error Resume Next With Application.FileDialog(msoFileDialogOpen) .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath .Filters.Clear: .Filters.Add FilterDescription, FilterExtention If .Show <> -1 Then Exit Function getFilePath = .SelectedItems(1): PS = Application.PathSeparator End With End Function
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then Set wbReturn = Workbooks.Open(Filename:=sFullName, ReadOnly:=False, Password:="456951") End If On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
[/vba]
не работает. читаю я нормально. Подскажите лучше код, я же написал что я не программист.Павел_леваП
я тоже - и дальше что? что именно не работает? какая ошибка вылезает? В сабе явно next-а не хватило: [vba]
Код
Sub архив()
Dim filePath As String filePath = getFilePath
If filePath = "" Then Exit Sub End If
Set storage = GetWorkbook(filePath)
For i = 7 To Sheets.Count If ActiveWorkbook.Sheets(i).Tab.Color = 10498160 Then Sheets(i).Move Before:=Workbooks("Архив.xls").Sheets(1) End If [b]next[/b]
End Sub
[/vba]
Цитата
я же написал что я не программист
я тоже - и дальше что? что именно не работает? какая ошибка вылезает? В сабе явно next-а не хватило: [vba]
Код
Sub архив()
Dim filePath As String filePath = getFilePath
If filePath = "" Then Exit Sub End If
Set storage = GetWorkbook(filePath)
For i = 7 To Sheets.Count If ActiveWorkbook.Sheets(i).Tab.Color = 10498160 Then Sheets(i).Move Before:=Workbooks("Архив.xls").Sheets(1) End If [b]next[/b]
Надо просто разобраться, к какой именно книге у вас относятся ActiveWorkbook, а также Sheets и Workbooks. Используйте префиксы ThisWorkbook (это книга, где находится макрос) и storage (это ваша открываемая книга), чтобы точно указывать источники/получатели.
по идее должен перенести листы в конец, т.е. найти в архиве последний лист и
никак не может быть "Before Sheet 1", скорее уж "After Sheet(Sheets.Count)"
Надо просто разобраться, к какой именно книге у вас относятся ActiveWorkbook, а также Sheets и Workbooks. Используйте префиксы ThisWorkbook (это книга, где находится макрос) и storage (это ваша открываемая книга), чтобы точно указывать источники/получатели.
1. У Вас активна какая книга в каком расширении? Если в xlsm или xlsb, то такие листы не скопируются в книгу с расширением xls - у них различное количество строк (в xlsm, xlsb 1048576, а в xls 65536) и столбцов (16384 и 256) 2. После того, как Вы скопировали первый лист, ActiveWorkbook-ом стала уже книга "Архив" и Вы копируете уже из нее, а Вам нужно из той, где макрос находится (если я правильно понял) 3. Допустим, в книге 8 листов. Вы хотите перенести листы 7 и 8. Перенесли лист 7, i стало равно 8, а в исходной книге-то уже не 8, а 7 листов, Вы ж седьмой оттуда убрали. Поэтому цикл нужно делать не с 7 до n, а с n до 7 В итоге получается примерно так [vba]
Код
For i = Sheets.Count To 7 Step -1 If ThisWorkbook.Sheets(i).Tab.Color = 10498160 Then ThisWorkbook.Sheets(i).Move Before:=Workbooks("Архив.xlsx").Sheets(1) End If Next i
[/vba] ======== Да, и Андрей еще про До и После написал. Это уже на размещение повлияет
1. У Вас активна какая книга в каком расширении? Если в xlsm или xlsb, то такие листы не скопируются в книгу с расширением xls - у них различное количество строк (в xlsm, xlsb 1048576, а в xls 65536) и столбцов (16384 и 256) 2. После того, как Вы скопировали первый лист, ActiveWorkbook-ом стала уже книга "Архив" и Вы копируете уже из нее, а Вам нужно из той, где макрос находится (если я правильно понял) 3. Допустим, в книге 8 листов. Вы хотите перенести листы 7 и 8. Перенесли лист 7, i стало равно 8, а в исходной книге-то уже не 8, а 7 листов, Вы ж седьмой оттуда убрали. Поэтому цикл нужно делать не с 7 до n, а с n до 7 В итоге получается примерно так [vba]
Код
For i = Sheets.Count To 7 Step -1 If ThisWorkbook.Sheets(i).Tab.Color = 10498160 Then ThisWorkbook.Sheets(i).Move Before:=Workbooks("Архив.xlsx").Sheets(1) End If Next i
[/vba] ======== Да, и Андрей еще про До и После написал. Это уже на размещение повлияет_Boroda_
Sub Мяу() Dim wb As Workbook Dim sFile$, s$, spl, i& For i = 7 To ThisWorkbook.Sheets.Count If Sheets(i).Tab.Color = 10498160 Then s = s & "," & Sheets(i).Name Next With Application.FileDialog(msoFileDialogOpen) .InitialFileName = ThisWorkbook.Path & Application.PathSeparator .Filters.Clear .Filters.Add "Книги Excel", "*.xls*" If .Show = 0 Then Exit Sub sFile = .SelectedItems(1) End With Set wb = Workbooks.Open(Filename:=sFile, Password:="") spl = (Split(Mid(s, 2), ",")) ReDim Preserve spl(1 To UBound(spl) + 1) ThisWorkbook.Sheets(spl).Move After:=wb.Sheets(wb.Sheets.Count)
End Sub
[/vba]
[vba]
Код
Sub Мяу() Dim wb As Workbook Dim sFile$, s$, spl, i& For i = 7 To ThisWorkbook.Sheets.Count If Sheets(i).Tab.Color = 10498160 Then s = s & "," & Sheets(i).Name Next With Application.FileDialog(msoFileDialogOpen) .InitialFileName = ThisWorkbook.Path & Application.PathSeparator .Filters.Clear .Filters.Add "Книги Excel", "*.xls*" If .Show = 0 Then Exit Sub sFile = .SelectedItems(1) End With Set wb = Workbooks.Open(Filename:=sFile, Password:="") spl = (Split(Mid(s, 2), ",")) ReDim Preserve spl(1 To UBound(spl) + 1) ThisWorkbook.Sheets(spl).Move After:=wb.Sheets(wb.Sheets.Count)