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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 212»
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос листов из одной книги в другую с условием переноса (Макросы/Sub)
Перенос листов из одной книги в другую с условием переноса
Павел_леваП Дата: Вторник, 08.08.2017, 13:25 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Добрый день, Уважаемые форумчане!

Помогите с макросом,
нужно чтобы макрос:
кнопка макроса должна быть в "Книга 1"
Файл "Книга 1" и "Архив" находятся в разных папках, соответственно нужен вызов проводника из "Книга 1" чтобы я мог выбрать нужный файл для архивации.

1. из "Книга 1" переносил листы в "Архив", поместить в конец книги.
2. условие переноса из "Книга 1" - цвет вкладки Color = 10498160.
3. удалить перенесенные листы из "Книга 1"
4. первые 6 листов в "Книга 1" удалять нельзя, надо их как-то закрепить в том плане что они не подлежат ни переносу, ни удалению

Заранее благодарю всех за помощь!
К сообщению приложен файл: _1.xlsx(16Kb) · 3292707.xlsx(11Kb)


Сообщение отредактировал Павел_леваП - Вторник, 08.08.2017, 13:33
 
Ответить
СообщениеДобрый день, Уважаемые форумчане!

Помогите с макросом,
нужно чтобы макрос:
кнопка макроса должна быть в "Книга 1"
Файл "Книга 1" и "Архив" находятся в разных папках, соответственно нужен вызов проводника из "Книга 1" чтобы я мог выбрать нужный файл для архивации.

1. из "Книга 1" переносил листы в "Архив", поместить в конец книги.
2. условие переноса из "Книга 1" - цвет вкладки Color = 10498160.
3. удалить перенесенные листы из "Книга 1"
4. первые 6 листов в "Книга 1" удалять нельзя, надо их как-то закрепить в том плане что они не подлежат ни переносу, ни удалению

Заранее благодарю всех за помощь!

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 13:25
Павел_леваП Дата: Вторник, 08.08.2017, 14:35 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Павел_леваП, вот что получается при записи макроса
[vba]
Код
Sub Макрос1()
'
' Макрос1 Макрос
'

'
Sheets(Array("Лист9", "Лист10", "Лист11", "Лист12", "Лист13", "Лист14", "Лист15")). _
Select
Sheets("Лист15").Activate
Sheets(Array("Лист9", "Лист10", "Лист11", "Лист12", "Лист13", "Лист14", "Лист15")). _
Copy Before:=Workbooks("Архив.xlsx").Sheets(9)
Windows("Книга 1.xlsx").Activate
Sheets(Array("Лист9", "Лист10", "Лист11", "Лист12", "Лист13", "Лист14", "Лист15")). _
Select
Sheets("Лист9").Activate
ActiveWindow.SelectedSheets.Delete
End Sub
[/vba]
К сообщению приложен файл: 0091323.xlsx(19Kb) · 3782163.xlsx(11Kb)


Сообщение отредактировал Павел_леваП - Вторник, 08.08.2017, 15:26
 
Ответить
СообщениеПавел_леваП, вот что получается при записи макроса
[vba]
Код
Sub Макрос1()
'
' Макрос1 Макрос
'

'
Sheets(Array("Лист9", "Лист10", "Лист11", "Лист12", "Лист13", "Лист14", "Лист15")). _
Select
Sheets("Лист15").Activate
Sheets(Array("Лист9", "Лист10", "Лист11", "Лист12", "Лист13", "Лист14", "Лист15")). _
Copy Before:=Workbooks("Архив.xlsx").Sheets(9)
Windows("Книга 1.xlsx").Activate
Sheets(Array("Лист9", "Лист10", "Лист11", "Лист12", "Лист13", "Лист14", "Лист15")). _
Select
Sheets("Лист9").Activate
ActiveWindow.SelectedSheets.Delete
End Sub
[/vba]

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 14:35
Павел_леваП Дата: Вторник, 08.08.2017, 14:46 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Павел_леваП, вот у меня есть макрос вызова проводника

[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
 
Ответить
СообщениеПавел_леваП, вот у меня есть макрос вызова проводника

[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 в 14:46
Павел_леваП Дата: Вторник, 08.08.2017, 17:31 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
не ужели это не возможно...?
я не программист
 
Ответить
Сообщениене ужели это не возможно...?
я не программист

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 17:31
Павел_леваП Дата: Вторник, 08.08.2017, 20:54 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Павел_леваП,
нашел макрос переноса листов начиная со 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
[/vba]

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 20:54
RAN Дата: Вторник, 08.08.2017, 21:03 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4545
Репутация: 920 ±
Замечаний: 0% ±

2010
Так включите наконец макрорекордер
[vba]
Код
Sub Макрос1()
    Sheets("Лист1").Select
    With ActiveWorkbook.Sheets("Лист1").Tab
        .Color = 255
        .TintAndShade = 0
    End With
End Sub
[/vba]
Отсюда вытекает
[vba]
Код
If ActiveWorkbook.Sheets("Лист1").Tab.Color = 255 Then
[/vba]
255 меняем на 10498160

[vba]
Код
Sub qq()
    For i = 7 To Sheets.Count
        If ActiveWorkbook.Sheets(i).Tab.Color = 255 Then
            ' делаю что хочу
        End If
    Next
End Sub
[/vba]


Быть или не быть, вот в чем загвоздка!

Сообщение отредактировал RAN - Вторник, 08.08.2017, 21:08
 
Ответить
СообщениеТак включите наконец макрорекордер
[vba]
Код
Sub Макрос1()
    Sheets("Лист1").Select
    With ActiveWorkbook.Sheets("Лист1").Tab
        .Color = 255
        .TintAndShade = 0
    End With
End Sub
[/vba]
Отсюда вытекает
[vba]
Код
If ActiveWorkbook.Sheets("Лист1").Tab.Color = 255 Then
[/vba]
255 меняем на 10498160

[vba]
Код
Sub qq()
    For i = 7 To Sheets.Count
        If ActiveWorkbook.Sheets(i).Tab.Color = 255 Then
            ' делаю что хочу
        End If
    Next
End Sub
[/vba]

Автор - RAN
Дата добавления - 08.08.2017 в 21:03
Павел_леваП Дата: Вторник, 08.08.2017, 21:28 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
RAN,
Вы наверное не правильно меня поняли - мне необходимо чтобы переносились только листы с цветом 10498160
 
Ответить
СообщениеRAN,
Вы наверное не правильно меня поняли - мне необходимо чтобы переносились только листы с цветом 10498160

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 21:28
RAN Дата: Вторник, 08.08.2017, 21:31 | Сообщение № 8
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4545
Репутация: 920 ±
Замечаний: 0% ±

2010
Вы, наверно, читаете через строку.
255 меняем на 10498160


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеВы, наверно, читаете через строку.
255 меняем на 10498160

Автор - RAN
Дата добавления - 08.08.2017 в 21:31
Павел_леваП Дата: Вторник, 08.08.2017, 21:44 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
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]

не работает.
читаю я нормально. Подскажите лучше код, я же написал что я не программист.
К сообщению приложен файл: _1.xlsm(34Kb)


Сообщение отредактировал Павел_леваП - Вторник, 08.08.2017, 21:57
 
Ответить
Сообщение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]

не работает.
читаю я нормально. Подскажите лучше код, я же написал что я не программист.

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 21:44
InExSu Дата: Вторник, 08.08.2017, 22:13 | Сообщение № 10
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 183
Репутация: 22 ±
Замечаний: 60% ±

Excel 2010
Цитата Павел_леваП, 08.08.2017 в 13:25, в сообщении № 1 ()
выбрать нужный файл для архивации

файл "Архив" у Вас будет регулярно в разных папках?


Сообщение отредактировал InExSu - Вторник, 08.08.2017, 22:14
 
Ответить
Сообщение
Цитата Павел_леваП, 08.08.2017 в 13:25, в сообщении № 1 ()
выбрать нужный файл для архивации

файл "Архив" у Вас будет регулярно в разных папках?

Автор - InExSu
Дата добавления - 08.08.2017 в 22:13
Павел_леваП Дата: Вторник, 08.08.2017, 22:21 | Сообщение № 11
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
InExSu, да.
поэтому я включил проводник чтобы выбрать файл
 
Ответить
СообщениеInExSu, да.
поэтому я включил проводник чтобы выбрать файл

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 22:21
buchlotnik Дата: Вторник, 08.08.2017, 22:30 | Сообщение № 12
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3109
Репутация: 851 ±
Замечаний: 0% ±

2010, 2013, 2016 RUS / ENG
Цитата
я же написал что я не программист
я тоже - и дальше что? что именно не работает? какая ошибка вылезает? В сабе явно 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]


каждому For - Next!
платная помощь:
ЯД: 410012595572239
buchlotnik@mail.ru
 
Ответить
Сообщение
Цитата
я же написал что я не программист
я тоже - и дальше что? что именно не работает? какая ошибка вылезает? В сабе явно 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]

Автор - buchlotnik
Дата добавления - 08.08.2017 в 22:30
Павел_леваП Дата: Вторник, 08.08.2017, 22:40 | Сообщение № 13
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
buchlotnik,
Цитата
я тоже - и дальше что?

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

вот здесь ошибка
[vba]
Код
Sheets(i).Move Before:=Workbooks("Архив.xls").Sheets(1)
[/vba]
по идее должен перенести листы в конец, т.е. найти в архиве последний лист и перенести туда все фиолетовые листы из Книги 1
 
Ответить
Сообщениеbuchlotnik,
Цитата
я тоже - и дальше что?

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

вот здесь ошибка
[vba]
Код
Sheets(i).Move Before:=Workbooks("Архив.xls").Sheets(1)
[/vba]
по идее должен перенести листы в конец, т.е. найти в архиве последний лист и перенести туда все фиолетовые листы из Книги 1

Автор - Павел_леваП
Дата добавления - 08.08.2017 в 22:40
AndreTM Дата: Вторник, 08.08.2017, 22:49 | Сообщение № 14
Группа: Друзья
Ранг: Старожил
Сообщений: 1762
Репутация: 496 ±
Замечаний: 0% ±

2003 & 2010
Надо просто разобраться, к какой именно книге у вас относятся ActiveWorkbook, а также Sheets и Workbooks.
Используйте префиксы ThisWorkbook (это книга, где находится макрос) и storage (это ваша открываемая книга), чтобы точно указывать источники/получатели.

Ну и
Цитата Павел_леваП, 08.08.2017 в 22:40, в сообщении № 13 ()
по идее должен перенести листы в конец, т.е. найти в архиве последний лист и
никак не может быть "Before Sheet 1", скорее уж "After Sheet(Sheets.Count)" :)


Skype: andre.tm.007
Donate: Qiwi: 9517375010
 
Ответить
СообщениеНадо просто разобраться, к какой именно книге у вас относятся ActiveWorkbook, а также Sheets и Workbooks.
Используйте префиксы ThisWorkbook (это книга, где находится макрос) и storage (это ваша открываемая книга), чтобы точно указывать источники/получатели.

Ну и
Цитата Павел_леваП, 08.08.2017 в 22:40, в сообщении № 13 ()
по идее должен перенести листы в конец, т.е. найти в архиве последний лист и
никак не может быть "Before Sheet 1", скорее уж "After Sheet(Sheets.Count)" :)

Автор - AndreTM
Дата добавления - 08.08.2017 в 22:49
_Boroda_ Дата: Вторник, 08.08.2017, 23:08 | Сообщение № 15
Группа: Модераторы
Ранг: Местный житель
Сообщений: 11512
Репутация: 4736 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
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_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение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_
Дата добавления - 08.08.2017 в 23:08
InExSu Дата: Среда, 09.08.2017, 08:26 | Сообщение № 16
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 183
Репутация: 22 ±
Замечаний: 60% ±

Excel 2010
Цитата Павел_леваП, 08.08.2017 в 13:25, в сообщении № 1 ()
выбрать нужный файл для архивации

Безблагодатное занятие.
Выкраивание листов - суета перед крахом.
Решите вопрос архивации специальными программами.
И душа будет спокойна!
 
Ответить
Сообщение
Цитата Павел_леваП, 08.08.2017 в 13:25, в сообщении № 1 ()
выбрать нужный файл для архивации

Безблагодатное занятие.
Выкраивание листов - суета перед крахом.
Решите вопрос архивации специальными программами.
И душа будет спокойна!

Автор - InExSu
Дата добавления - 09.08.2017 в 08:26
RAN Дата: Среда, 09.08.2017, 11:14 | Сообщение № 17
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4545
Репутация: 920 ±
Замечаний: 0% ±

2010
[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)

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)

End Sub
[/vba]

Автор - RAN
Дата добавления - 09.08.2017 в 11:14
RAN Дата: Среда, 09.08.2017, 11:26 | Сообщение № 18
Группа: Друзья
Ранг: Участник клуба
Сообщений: 4545
Репутация: 920 ±
Замечаний: 0% ±

2010
Интересное явление обнаружил.
В процессе отладки макрос без строки
[vba]
Код
ReDim Preserve spl(1 To UBound(spl) + 1)
[/vba]
выдавал ошибку 9 (не соответствие типов).
Я впал в ступор.
После перезагрузки Excel пропало, так что эта строка лишняя.


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеИнтересное явление обнаружил.
В процессе отладки макрос без строки
[vba]
Код
ReDim Preserve spl(1 To UBound(spl) + 1)
[/vba]
выдавал ошибку 9 (не соответствие типов).
Я впал в ступор.
После перезагрузки Excel пропало, так что эта строка лишняя.

Автор - RAN
Дата добавления - 09.08.2017 в 11:26
Павел_леваП Дата: Среда, 09.08.2017, 15:24 | Сообщение № 19
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
RAN, Спасибо, большое!
Все работает, даже с этой строкой
[vba]
Код
ReDim Preserve spl(1 To UBound(spl) + 1)
[/vba]
расскажите пожалуйста что делает данная строка
 
Ответить
СообщениеRAN, Спасибо, большое!
Все работает, даже с этой строкой
[vba]
Код
ReDim Preserve spl(1 To UBound(spl) + 1)
[/vba]
расскажите пожалуйста что делает данная строка

Автор - Павел_леваП
Дата добавления - 09.08.2017 в 15:24
Павел_леваП Дата: Среда, 09.08.2017, 15:46 | Сообщение № 20
Группа: Пользователи
Ранг: Новичок
Сообщений: 32
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
при интеграции макроса в файл выдает ошибку: Run-time Error 1004 Метод Move из класса Sheets завершен не верно
подсвечивает эту строку
[vba]
Код
ThisWorkbook.Sheets(spl).Move After:=wb.Sheets(wb.Sheets.Count)
[/vba]
 
Ответить
Сообщениепри интеграции макроса в файл выдает ошибку: Run-time Error 1004 Метод Move из класса Sheets завершен не верно
подсвечивает эту строку
[vba]
Код
ThisWorkbook.Sheets(spl).Move After:=wb.Sheets(wb.Sheets.Count)
[/vba]

Автор - Павел_леваП
Дата добавления - 09.08.2017 в 15:46
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос листов из одной книги в другую с условием переноса (Макросы/Sub)
Страница 1 из 212»
Поиск:

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