Макрос переноса листов в другую книгу excel

 

День добрый!
через поиск не нашел подходящего.
Задача: На активном листе делаю кнопочку с макросом, который

по указанному пути

переносит/копирует (если есть возможность сделать выбор) весь Лист (активный) с данными в др книгу.

Такое ведь можно делать?

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

Сначала записать макрорекодером…

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#3

05.09.2018 15:02:40

Цитата
Александр написал: Такое ведь можно делать?

конечно можно. Только не понятно где будет

Цитата
Александр написал: по указанному пути

но Если кнопка на листе, а лист весь перенесется то , ту два варианта, либо макрос перенесется вместе с листом, либо на перенесенном листе кнопка работать не будет

«Все гениальное просто, а все простое гениально!!!»

 

StoTisteg

Пользователь

Сообщений: 441
Регистрация: 07.05.2018

#4

05.09.2018 15:07:44

Цитата
Nordheim написал:
либо макрос перенесется вместе с листом, либо на перенесенном листе кнопка работать не будет

… либо и то, и другое — если макросы в модуле листа есть, но кнопочка вызывает не их.

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#5

05.09.2018 15:08:04

vikttur, А как? если только при открытой книге

Цитата
Nordheim написал:
но Если кнопка на листе, а лист весь перенесется то

Это уже не важно. Главное что бы срабатывал на активный лист (а то в каждой книге постоянно дополняются новыми листами, а их сейчас уже по 100)  

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

#6

05.09.2018 15:09:41

Цитата
Александр написал:  vikttur , А как?

Записать -> посмотреть -> попытаться разобраться -> попытаться  изменить.
Хоть что-то из этой цепочки пробовали? Если да — показываете пример с полученным чудом и просите дальнейшей помощи.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#7

05.09.2018 15:14:55

Цитата
Александр написал: Это уже не важно

Так если кнопка на одном листе только это т лист и можно будет перенести, в чем смысл гонять один?
Или Вы собираетесь на всех 100 листах кнопки сделать, а стоит ли овчинка выделки? Честно говоря не вижу смысла в реализации данного вопроса.
м.б. Вам подумать как это сделать без кнопок на листе, и воспользовавшись советом от vikttur, записать макрорекодером а потом юзать макрос на активных листах в активной книге.

«Все гениальное просто, а все простое гениально!!!»

 

StoTisteg

Пользователь

Сообщений: 441
Регистрация: 07.05.2018

… или выбирать переносимые листы в ListBox’е…

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#9

05.09.2018 15:23:08

vikttur, Остановился только на «думал» тк
1. Требуется указать путь (тк этих книг несколько) и делать на каждую отдельно кнопку
2. Требуется открывать каждый раз книгу в которую перенести этот лист
По отдельности это еще можно, а все вместе становится делом «муторным»

Цитата
Nordheim написал:
на всех 100 листах кнопки сделать, а стоит ли овчинка выделки

У меня шаблон по которому создаются эти все листы с данными. Я эту кнопку «впаяю» в этот шаблон и все дела. А по уже созданным  — в ручную.

Цитата
Nordheim написал:
Честно говоря не вижу смысла в реализации данного вопроса.

Книги активно заполняются/исправляются каждый день разными пользователями. Стараюсь сделать работу более комфортной  

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Они по факту идентичные (книги), но из-за того, что на офисе 13 не возможно реализовать общее редактирование, разнес на каждого пользователя по книге

Изменено: Александр05.09.2018 15:26:31

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#11

05.09.2018 15:37:31

Цитата
Александр написал:
Я эту кнопку «впаяю»

А ссылку на код переноса тоже впаяете?

«Все гениальное просто, а все простое гениально!!!»

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#12

05.09.2018 15:47:18

Nordheim, Вы серьезно? я не селен в ВБФ, но у меня уже работает на этом принципе
Этот код отрабатывается на каждом листе по отдельности. Код сохранен в «Этокнига»

Код
Option Explicit
Sub GetFromAct()
Dim arrFull(), Temp, X
Dim t@, nr&, nc%, r&, c%, i&, n&
Dim whatFind$, delimList$
Application.ScreenUpdating = 0: On Error GoTo er: delimList = ";": t = Timer
 
arrFull = [??].Value
nr = [??].Rows.Count: nc = [??].Columns.Count
whatFind = ActiveSheet.Range("E10").Value
 
ReDim arrFind(0 To nr * (nc - 1)): i = -1
    For n = 1 To nr
        Temp = Replace$(arrFull(n, 4), delimList, Chr(32))
        Temp = Application.WorksheetFunction.Trim(Temp)
        Temp = "%%%" & Replace$(Temp, Chr(32), "%%%") & "%%%"
            If InStr(Temp, "%%%" & whatFind & "%%%") > 0 Then
                For c = 2 To nc
                    i = i + 1
                    arrFind(i) = arrFull(n, c)
                Next c
            End If
    Next n
If i < 0 Then MsgBox "?????? ?? ???????", vbInformation, "?????? ????????": GoTo fin
ReDim Preserve arrFind(0 To i)
nc = nc - 1: nr = (i + 1) / nc
ReDim arrInput(1 To nr, 1 To nc): n = 0: i = 0
    For r = 1 To nr
        For c = 1 To nc
            arrInput(r, c) = arrFind(i)
            i = i + 1
        Next c
    Next r
ActiveSheet.Range("T8").Resize(nr, nc).Value = arrInput
t = Round((Timer - t) * 1000, 4)
MsgBox "?????? ?????????!" & vbLf & vbLf & "????? ??????: " & t, vbInformation, "??????"
GoTo fin
er: MsgBox "?????????????? ??????!", vbCritical, "?????? ?????????"
ex: MsgBox "??????", vbInformation, "?????"
fin: On Error GoTo 0: Application.ScreenUpdating = 1
End Sub

Изменено: Александр05.09.2018 15:50:15

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#13

05.09.2018 15:56:09

Цитата
Александр написал:
но у меня уже работает на этом принципе

На каком принципе, у вас каждый раз генерируется кнопка на листе с уже действующей ссылкой на ранее созданный код?

«Все гениальное просто, а все простое гениально!!!»

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#14

05.09.2018 16:00:38

Цитата
Nordheim написал:
у вас каждый раз генерируется кнопка на листе

так да. У меня шаблон в котором «эта кнопка» — которая занимается поиском значений и выводом на этот лист(активный)
потом макроредактором сделал простую кнопку «скопировать» шаблон где происходит раб процессы и кнопка работает

Цитата
Nordheim написал:
ссылкой на ранее созданный код

именно

Код
whatFind = ActiveSheet.Range("E10").Value

Изменено: Александр05.09.2018 16:01:02

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

Когда у Вас будет создана кнопка, код  с переносом листа для нее вы сами пропишите или тоже макросом?

«Все гениальное просто, а все простое гениально!!!»

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#16

05.09.2018 16:11:55

Не совсем понимаю Вашего вопроса.

Код
  Sheets("Шаблон (60)").Select - тут, как я понимаю, должен появится оператор активный лист
    Sheets("Шаблон (60)").Copy Before:=Workbooks( _
        "Некая книга.xlsm").Sheets(1)тут выбор куда скопировать

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

Вы перенесли лист в «некую книгу» вместе с кнопкой. В книге источнике откуда появится лист с еще одной кнопкой? Ведь Вы просите кнопку на листе, а лист перенесли в «некую книгу» вместе с кнопкой. Далее Вы в книге Источнике формируете лист с кнопкой , но кнопка не ссылается ни на какой код. И что дальше вы намерены делать?

«Все гениальное просто, а все простое гениально!!!»

 

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

#18

05.09.2018 16:23:41

О кнопке не понял… Код для копирования активного листа в другую книгу

Код
    sPath = "тут полный путь к книге с именем и расширением"
    Set sht = ActiveSheet ' объект в переменную

    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
    Set wBook = Workbooks.Open(Filename:=sPath) 
        
    With wBook
        sht.Copy Before:=.Sheets(1) 
    
        With .Sheets(1) 
            ' если нужно, меняем имя, работаем  листом...
        End With
        
        .Save: .Close
    End With

    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
 

Nordheim, А Вы про это. Еще раз
Шаг 1 — создается Лист «Шаблон» в который я «впаяю» данный макрос с кнопкой
Шаг 2 — Создается кнопка «Копировать Шаблон» теперь это Лист «Шаблон (1)» и т.д.
Шаг 3 — нажимаю эту кнопку на Листе «Шаблон N» и переношу его в др книгу
т.е. на каждом листе у меня будет уже кнопка

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

#20

05.09.2018 16:28:27

Цитата
Александр написал:
нажимаю эту кнопку

А вы уверены, что что-то произойдет?

«Все гениальное просто, а все простое гениально!!!»

 

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

Ну смотрите я предупредил, ваша вновь созданная кнопка будет просто муляжом. Жаль что Вы так и не поняли суть темы обсуждения.
Удачи.

Изменено: Nordheim05.09.2018 16:37:48

«Все гениальное просто, а все простое гениально!!!»

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#23

06.09.2018 08:38:50

Цитата
Nordheim написал:
Жаль что Вы так и не поняли суть темы обсуждения.

К сожалею, да.  

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Nordheim

Пользователь

Сообщений: 3154
Регистрация: 18.04.2017

А Вы попробуйте сделать кнопку, и понажимать , что будет происходить?

«Все гениальное просто, а все простое гениально!!!»

 

Юрий М

Модератор

Сообщений: 60585
Регистрация: 14.09.2012

Контакты см. в профиле

#25

06.09.2018 12:47:50

Александр, Может это поможет?

Код
ActiveSheet.Shapes("Button 1").OnAction = "Module1.Macro1"

 

vikttur

Пользователь

Сообщений: 47199
Регистрация: 15.09.2012

#26

06.09.2018 17:16:41

Код в сообщеии №18 — для марсиан? От автора темы — ни пол-слова…

Цитата
Так скажите, ради осьминога, для чего учиться [помогать]?
 

vikttur, Оо, честное слово не увидел Вашего кода (сообщения).
Искренни извиняюсь за ложное представление о моем наплевательском отношение.
Сегодня/завтра протестирую — отпишусь

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Юрий М

Модератор

Сообщений: 60585
Регистрация: 14.09.2012

Контакты см. в профиле

Александр, а моё сообщение видели? )

 

Юрий М, Видел, все проверю:)  

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

 

Александр

Пользователь

Сообщений: 1021
Регистрация: 29.07.2018

#30

07.09.2018 09:34:52

vikttur, Что то не так. Как я понял — не работает :)
Юрий М, Вашу в 2 строку вставлял, не помогает

Указывал путь и в кавычках и без
Я не понимаю в коде, в этом и сложность

Прикрепленные файлы

  • Безымянный.png (118.59 КБ)

В жизни нет ничего невозможного! Есть только недостаток знаний и умений.

So, what I want to do, generally, is make a copy of a workbook. However, the source workbook is running my macros, and I want it to make an identical copy of itself, but without the macros. I feel like there should be a simple way to do this with VBA, but have yet to find it. I am considering copying the sheets one by one to the new workbook, which I will create. How would I do this? Is there a better way?

Martijn Pieters's user avatar

asked Jul 28, 2011 at 18:34

Brian's user avatar

1

I would like to slightly rewrite keytarhero’s response:

Sub CopyWorkbook()

Dim sh as Worksheet,  wb as workbook

Set wb = workbooks("Target workbook")
For Each sh in workbooks("source workbook").Worksheets
   sh.Copy After:=wb.Sheets(wb.sheets.count) 
Next sh

End Sub

Edit: You can also build an array of sheet names and copy that at once.

Workbooks("source workbook").Worksheets(Array("sheet1","sheet2")).Copy _
         After:=wb.Sheets(wb.sheets.count)

Note: copying a sheet from an XLS? to an XLS will result into an error. The opposite works fine (XLS to XLSX)

answered Jul 28, 2011 at 21:05

iDevlop's user avatar

iDevlopiDevlop

24.6k11 gold badges89 silver badges147 bronze badges

3

Someone over at Ozgrid answered a similar question. Basically, you just copy each sheet one at a time from Workbook1 to Workbook2.

Sub CopyWorkbook()

    Dim currentSheet as Worksheet
    Dim sheetIndex as Integer
    sheetIndex = 1

    For Each currentSheet in Worksheets

        Windows("SOURCE WORKBOOK").Activate 
        currentSheet.Select
        currentSheet.Copy Before:=Workbooks("TARGET WORKBOOK").Sheets(sheetIndex) 

        sheetIndex = sheetIndex + 1

    Next currentSheet

End Sub

Disclaimer: I haven’t tried this code out and instead just adopted the linked example to your problem. If nothing else, it should lead you towards your intended solution.

Community's user avatar

answered Jul 28, 2011 at 19:05

Chris Flynn's user avatar

Chris FlynnChris Flynn

9536 silver badges11 bronze badges

2

You could saveAs xlsx. Then you will loose the macros and generate a new workbook with a little less work.

ThisWorkbook.saveas Filename:=NewFileNameWithPath, Format:=xlOpenXMLWorkbook

answered Jul 28, 2011 at 20:55

Brad's user avatar

BradBrad

11.9k4 gold badges44 silver badges70 bronze badges

2

I was able to copy all the sheets in a workbook that had a vba app running, to a new workbook w/o the app macros, with:

ActiveWorkbook.Sheets.Copy

Prashant Kumar's user avatar

answered Feb 28, 2014 at 17:50

George Ziniewicz's user avatar

Assuming all your macros are in modules, maybe this link will help. After copying the workbook, just iterate over each module and delete it

Community's user avatar

answered Jul 28, 2011 at 18:59

raven's user avatar

ravenraven

4376 silver badges17 bronze badges

Try this instead.

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
    ws.Copy
Next

ZygD's user avatar

ZygD

21k39 gold badges77 silver badges98 bronze badges

answered Jan 17, 2013 at 21:28

Ch3knraz3's user avatar

You can simply write

Worksheets.Copy

in lieu of running a cycle.
By default the worksheet collection is reproduced in a new workbook.

It is proven to function in 2010 version of XL.

iDevlop's user avatar

iDevlop

24.6k11 gold badges89 silver badges147 bronze badges

answered Feb 17, 2015 at 14:25

Hors2force's user avatar

Hors2forceHors2force

1011 silver badge2 bronze badges

    Workbooks.Open Filename:="Path(Ex: C:ReportsClientWiseReport.xls)"ReadOnly:=True


    For Each Sheet In ActiveWorkbook.Sheets

        Sheet.Copy After:=ThisWorkbook.Sheets(1)

    Next Sheet

answered Feb 22, 2013 at 11:39

Sainath J's user avatar

Here is one you might like it uses the Windows FileDialog(msoFileDialogFilePicker) to browse to a closed workbook on your desktop, then copies all of the worksheets to your open workbook:

Sub CopyWorkBookFullv2()
Application.ScreenUpdating = False

Dim ws As Worksheet
Dim x As Integer
Dim closedBook As Workbook
Dim cell As Range
Dim numSheets As Integer
Dim LString As String
Dim LArray() As String
Dim dashpos As Long
Dim FileName As String

numSheets = 0

For Each ws In Application.ActiveWorkbook.Worksheets
    If ws.Name <> "Sheet1" Then
       Sheets.Add.Name = "Sheet1"
   End If
Next

Dim fileExplorer As FileDialog
Set fileExplorer = Application.FileDialog(msoFileDialogFilePicker)
Dim MyString As String

fileExplorer.AllowMultiSelect = False

  With fileExplorer
     If .Show = -1 Then 'Any file is selected
     MyString = .SelectedItems.Item(1)

     Else ' else dialog is cancelled
        MsgBox "You have cancelled the dialogue"
        [filePath] = "" ' when cancelled set blank as file path.
        End If
    End With

    LString = Range("A1").Value
    dashpos = InStr(1, LString, "") + 1
    LArray = Split(LString, "")
    'MsgBox LArray(dashpos - 1)
    FileName = LArray(dashpos)

strFileName = CreateObject("WScript.Shell").specialfolders("Desktop") & "" & FileName

Set closedBook = Workbooks.Open(strFileName)
closedBook.Application.ScreenUpdating = False
numSheets = closedBook.Sheets.Count

        For x = 1 To numSheets
            closedBook.Sheets(x).Copy After:=ThisWorkbook.Sheets(1)
        x = x + 1
                 If x = numSheets Then
                    GoTo 1000
                 End If
Next

1000

closedBook.Application.ScreenUpdating = True
closedBook.Close
Application.ScreenUpdating = True

End Sub

answered Apr 5, 2020 at 22:26

RWB's user avatar

try this one

Sub Get_Data_From_File()

     'Note: In the Regional Project that's coming up we learn how to import data from multiple Excel workbooks
    ' Also see BONUS sub procedure below (Bonus_Get_Data_From_File_InputBox()) that expands on this by inlcuding an input box
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook
    Application.ScreenUpdating = False
    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*xls*")
    If FileToOpen <> False Then
        Set OpenBook = Application.Workbooks.Open(FileToOpen)
         'copy data from A1 to E20 from first sheet
        OpenBook.Sheets(1).Range("A1:E20").Copy
        ThisWorkbook.Worksheets("SelectFile").Range("A10").PasteSpecial xlPasteValues
        OpenBook.Close False
        
    End If
    Application.ScreenUpdating = True
End Sub

or this one:

Get_Data_From_File_InputBox()

Dim FileToOpen As Variant
Dim OpenBook As Workbook
Dim ShName As String
Dim Sh As Worksheet
On Error GoTo Handle:

FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", FileFilter:="Excel Files (*.xls*),*.xls*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If FileToOpen <> False Then
    Set OpenBook = Application.Workbooks.Open(FileToOpen)
    ShName = Application.InputBox("Enter the sheet name to copy", "Enter the sheet name to copy")
    For Each Sh In OpenBook.Worksheets
        If UCase(Sh.Name) Like "*" & UCase(ShName) & "*" Then
            ShName = Sh.Name
        End If
    Next Sh

    'copy data from the specified sheet to this workbook - updae range as you see fit
    OpenBook.Sheets(ShName).Range("A1:CF1100").Copy
    ThisWorkbook.ActiveSheet.Range("A10").PasteSpecial xlPasteValues
    OpenBook.Close False
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub

Handle:
If Err.Number = 9 Then
MsgBox «The sheet name does not exist. Please check spelling»
Else
MsgBox «An error has occurred.»
End If
OpenBook.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

both work as

answered Jul 6, 2020 at 4:26

Silvio Rivas's user avatar

Перенос листов из одной книги в другую с условием переноса

Павел_леваП

Дата: Вторник, 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» удалять нельзя, надо их как-то закрепить в том плане что они не подлежат ни переносу, ни удалению

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

Сообщение отредактировал Павел_леваПВторник, 08.08.2017, 13:33

 

Ответить

Павел_леваП

Дата: Вторник, 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]

Сообщение отредактировал Павел_леваПВторник, 08.08.2017, 15:26

 

Ответить

Павел_леваП

Дата: Вторник, 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

 

Ответить

Павел_леваП

Дата: Вторник, 08.08.2017, 17:31 |
Сообщение № 4

Группа: Пользователи

Ранг: Новичок

Сообщений: 32


Репутация:

0

±

Замечаний:
0% ±


Excel 2013

не ужели это не возможно…?
я не программист

 

Ответить

Павел_леваП

Дата: Вторник, 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]

 

Ответить

RAN

Дата: Вторник, 08.08.2017, 21:03 |
Сообщение № 6

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Так включите наконец макрорекордер
[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

 

Ответить

Павел_леваП

Дата: Вторник, 08.08.2017, 21:28 |
Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 32


Репутация:

0

±

Замечаний:
0% ±


Excel 2013

RAN,
Вы наверное не правильно меня поняли — мне необходимо чтобы переносились только листы с цветом 10498160

 

Ответить

RAN

Дата: Вторник, 08.08.2017, 21:31 |
Сообщение № 8

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Вы, наверно, читаете через строку.


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

 

Ответить

Павел_леваП

Дата: Вторник, 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
(33.5 Kb)

Сообщение отредактировал Павел_леваПВторник, 08.08.2017, 21:57

 

Ответить

InExSu

Дата: Вторник, 08.08.2017, 22:13 |
Сообщение № 10

Группа: Друзья

Ранг: Ветеран

Сообщений: 646


Репутация:

96

±

Замечаний:
0% ±


Excel 2010

выбрать нужный файл для архивации

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


Разработчик Битрикс24 php, Google Apps Script, VBA Excel

Сообщение отредактировал InExSuВторник, 08.08.2017, 22:14

 

Ответить

Павел_леваП

Дата: Вторник, 08.08.2017, 22:21 |
Сообщение № 11

Группа: Пользователи

Ранг: Новичок

Сообщений: 32


Репутация:

0

±

Замечаний:
0% ±


Excel 2013

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

 

Ответить

buchlotnik

Дата: Вторник, 08.08.2017, 22:30 |
Сообщение № 12

Группа: Заблокированные

Ранг: Участник клуба

Сообщений: 3442


Репутация:

929

±

Замечаний:
20% ±


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]

 

Ответить

Павел_леваП

Дата: Вторник, 08.08.2017, 22:40 |
Сообщение № 13

Группа: Пользователи

Ранг: Новичок

Сообщений: 32


Репутация:

0

±

Замечаний:
0% ±


Excel 2013

buchlotnik,

Цитата

я тоже — и дальше что?

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

вот здесь ошибка
[vba]

Код

Sheets(i).Move Before:=Workbooks(«Архив.xls»).Sheets(1)

[/vba]
по идее должен перенести листы в конец, т.е. найти в архиве последний лист и перенести туда все фиолетовые листы из Книги 1

 

Ответить

AndreTM

Дата: Вторник, 08.08.2017, 22:49 |
Сообщение № 14

Группа: Друзья

Ранг: Старожил

Сообщений: 1762


Репутация:

498

±

Замечаний:
0% ±


2003 & 2010

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

Ну и

по идее должен перенести листы в конец, т.е. найти в архиве последний лист и

никак не может быть «Before Sheet 1», скорее уж «After Sheet(Sheets.Count)» :)


Skype: andre.tm.007
Donate: Qiwi: 9517375010

 

Ответить

_Boroda_

Дата: Вторник, 08.08.2017, 23:08 |
Сообщение № 15

Группа: Модераторы

Ранг: Местный житель

Сообщений: 16618


Репутация:

6465

±

Замечаний:
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

 

Ответить

InExSu

Дата: Среда, 09.08.2017, 08:26 |
Сообщение № 16

Группа: Друзья

Ранг: Ветеран

Сообщений: 646


Репутация:

96

±

Замечаний:
0% ±


Excel 2010

выбрать нужный файл для архивации

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


Разработчик Битрикс24 php, Google Apps Script, VBA Excel

 

Ответить

RAN

Дата: Среда, 09.08.2017, 11:14 |
Сообщение № 17

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

[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:26 |
Сообщение № 18

Группа: Друзья

Ранг: Экселист

Сообщений: 5645

Интересное явление обнаружил.
В процессе отладки макрос без строки
[vba]

Код

ReDim Preserve spl(1 To UBound(spl) + 1)

[/vba]
выдавал ошибку 9 (не соответствие типов).
Я впал в ступор.
После перезагрузки Excel пропало, так что эта строка лишняя.


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

 

Ответить

Павел_леваП

Дата: Среда, 09.08.2017, 15:24 |
Сообщение № 19

Группа: Пользователи

Ранг: Новичок

Сообщений: 32


Репутация:

0

±

Замечаний:
0% ±


Excel 2013

RAN, Спасибо, большое!
Все работает, даже с этой строкой
[vba]

Код

ReDim Preserve spl(1 To UBound(spl) + 1)

[/vba]
расскажите пожалуйста что делает данная строка

 

Ответить

Павел_леваП

Дата: Среда, 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]

 

Ответить

Задача состоит в том, чтобы скопировать определенный диапазон текущего листа, открыть другую книгу, и вставить эти скопированные данные в определенную ячейку, сохранить этот файл и закрыть. Ниже приведен код VBA.

Sub Название_Макроса()

'Выделить диапазон который необходимо скопировать
Range("A1:F52").Select
'Скопировать то, что выделено
Selection.Copy
ChDir "путь к папке где лежит файл в который необходимо скопировать"
Workbooks.Open Filename:= "Название файла, который находится в папке, путь к которой указан выше"
'Выделить начальную ячейку в которую необходимо вставить скопированные данные
Range("A6").Select
'Вставить данные
ActiveSheet.Paste
'сохранить текущую книгу
ActiveWorkbook.Save
'Закрыть книгу
ActiveWorkbook.Close
End Sub

Вариант 2: В открывшейся книге запускаем макрос, чтобы он открыл нужную нам книгу, скопировал от туда нужные нам данные и вставил в нашу открытую книгу, закрыв файл из которого эти данные были скопированы

Sub Название_Макроса2()
'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:Данные.xlsx"

'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("Данные.xlsx").Worksheets("Лист1").Range("A16:E16").Copy
'Активируем нужную нам книгу
Workbooks("Книга1.xlsm").Activate

'Выделяем и вставляем скопированные данные в ячейку А1
ActiveWorkbook.Worksheets("Лист1").Range("A1").Select
ActiveSheet.Paste

'Закрываем книгу откуда мы скопировали данные
Workbooks("Данные.xlsx").Close

End Sub

Еще пример — Скопировать диапазоны данных из активной открытой книги Excel нескольких листов (в нашем примере 3-х листов) в другую книгу, которая хранится в определенном месте. Данные будут вставлены как значения, плюс будут перенесены форматы ячеек.

Sub Копируем_листы_в_другую_книгу()
Dim bookconst As Workbook
Dim abook As Workbook
Set abook = ActiveWorkbook 'присваиваем перменную активной книге
Set bookconst = Workbooks.Open("C:UsersUserDesktop1.xlsx") 'присваиваем перменную книге куда необходимо копировать данные

'переходим в активную книгу откуда необходимо скопировать данные
abook.Worksheets("Лист1").Activate
Range("A1:I23").Copy 'копируем определенный диапазон листа, укажите свой диапазон
bookconst.Worksheets("Лист1").Activate 'активируем лист куда необходимо вставить данные
Range("A1:I23").Select 'встаем на ячейку А1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'второй лист
abook.Worksheets("Лист2").Activate
Range("A1:I23").Copy
bookconst.Worksheets("Лист2").Activate
Range("A1:I23").Select 'выделяем диапазон
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'третий лист
abook.Worksheets("Лист3").Activate
Range("A1:I23").Copy
bookconst.Worksheets("Лист3").Activate
Range("A1:I23").Select 'выделяем диапазон
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'сохранить текущую книгу
bookconst.Save
'Закрыть книгу
bookconst.Close
abook.Activate

End Sub

Если статья была вам полезна, то буду благодарен, если вы поделитесь ей со своими друзьями с помощью кнопок расположенных ниже.

Спасибо за внимание.

You can easily copy sheets in Excel manually with a few simple mouse clicks. On the other hand, you need a macro if you want to automate this process. In this guide, we’re going to show you how to copy sheets in Excel with VBA.

Download Workbook

Before you start

If you are new to VBA and macro concept, VBA is a programming language for Office products. Microsoft allows users to automate tasks or modify properties of Office software. A macro, on the other hand, is a set of VBA code which you tell the machine what needs to be done.

Macros, or codes, should be written in modules, which are text areas in VBA’s dedicated user interface. Also, the file should be saved as Excel Macro Enabled Workbook in XLSM format to keep the codes.

You can find detailed instructions in our How to create a macro in Excel guide.

New Workbook

Copy active sheet to a new workbook

The first code is the simplest and shortest one which performs the action the title suggests:

Public Sub CopyActiveSheetToNewWorkbook()

  ActiveSheet.Copy

End Sub

As you can figure out ActiveSheet selector indicates the active sheet in the user window. Once the code run successfully, you will see the copy in a new workbook.

Copy a specific sheet to a new workbook

The following code copies “SUMIFS” sheet into a new workbook, regardless of sheet’s active status.

Public Sub CopySpecificSheetToNewWorkbook()

  Sheets("SUMIFS").Copy

End Sub

Copy selected sheets to a new workbook

If you need to copy selected sheets into a new workbook, use ActiveWindow.SelectedSheets selector.

Public Sub CopyActiveSheetsToNewWorkbook()

  ActiveWindow.SelectedSheets.Copy

End Sub

Copy active sheet to a specific position in the same workbook

If you specify a position in the code, VBA duplicates the sheet in a specific position of in the workbook. To do this placement, you can use Before and After arguments with Copy command. With these arguments, you can place the new sheet before or after an existing worksheet.

You can use either sheet names or their indexes to indicate the existing sheet. Here are a few samples:

Public Sub CopyActiveSheetAfterSheet_Name()

  'Copies the active sheet after "Types" sheet

  ActiveSheet.Copy After:=Sheets("Types")

End Sub

    

Public Sub CopyActiveSheetAfterSheet_Index()

  'Copies after 2nd sheet

  ActiveSheet.Copy After:=Sheets(2)

End Sub

    

Public Sub CopyActiveSheetAfterLastSheet()

  'Copies the active sheet after the last sheet

  'Sheets.Count command returns the number of the sheets in the workbook

  ActiveSheet.Copy After:=Sheets(Sheets.Count)

End Sub

    

Public Sub CopyActiveSheetBeforeSheet_Name()

  'Copies the active sheet before "Types" sheet

  ActiveSheet.Copy Before:=Sheets("Types")

End Sub

    

Public Sub CopyActiveSheetBeforeSheet_Index()

  'Copies the active sheet before 2nd sheet

  ActiveSheet.Copy Before:=Sheets(2)

End Sub

    

Public Sub CopyActiveSheetBeforeFirstSheet()

  'Copies the active sheet before the first sheet

  ActiveSheet.Copy Before:=Sheets(1)

End Sub

Copy active sheet to an existing workbook

To copy anything to an existing workbook, there are 2 perquisites:

  1. Target workbook should be open as well
  2. You need to specify the target workbooks by name
Sub CopySpecificSheetToExistingWorkbook()

  ' define a workbook variable and assign target workbook

  ' thus, we can use variable multiple times instead of workbook reference

  Dim targetSheet As Workbook

  Set targetSheet = Workbooks("Target Workbook.xlsx")

  'copies "Names" sheet to the last position in the target workbook

  Sheets("Names").Copy After:=targetSheet.Sheets(targetSheet.Worksheets.Count)

End Sub

Note: To copy to a closed workbook is possible. However, the target workbook should be opened and preferably closed after copying via VBA as well.

Понравилась статья? Поделить с друзьями:
  • Макрос переноса всех данных с одного файла в другой excel
  • Макрос при расчетах в excel
  • Макрос перемещения ячейки excel
  • Макрос при закрытии книги excel
  • Макрос переключения листов в excel