Страницы: 1
RSS
Наполнение новой книги листами из текущей.
 

День добрый!

Помогите доработать этот макрос, что б он сохранял листы в новую книгу, а не в текущую.

Код
Sub qwe()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Integer, lr As Integer

Set ws1 = ThisWorkbook.Worksheets("ТТ")
Set ws2 = ThisWorkbook.Worksheets("МСК")
Set ws3 = ThisWorkbook.Worksheets("Back")

lr = ws1.Cells(Rows.Count, 4).End(xlUp).Row
With ws2
For i = 10 To lr
    If ws1.Cells(i, 1) <> "" Then
    ws2.Copy , Worksheets(Worksheets.Count)
    wsC = Sheets.Count
    Sheets(wsC).Name = ws1.Cells(i, 2)
    Sheets(wsC).Cells(6, 43) = ws1.Cells(2, 16)
    Sheets(wsC).Cells(6, 1) = ws1.Cells(i, 6)
    Sheets(wsC).Cells(10, 1) = ws1.Cells(i, 14)
    Sheets(wsC).Cells(6, 23) = ws1.Cells(4, 16)
    
    
    End If
Next i

End With
Application.ScreenUpdating = True
End Sub
Изменено: tsutse - 14.12.2018 15:36:40
 
Так создайте ее и переносите.
"Все гениальное просто, а все простое гениально!!!"
 
Так вот как к ней обратиться?
 
Так что бы обратиться, нужно создать. У вас макрос рабочий? если не учитывать перемещение листов в новую книгу?
Изменено: Nordheim - 14.12.2018 16:07:08
"Все гениальное просто, а все простое гениально!!!"
 
Ну создается она после
Код
ws2.Copy
А как набить ее листами?

Макрос - да, рабочий
Изменено: tsutse - 14.12.2018 16:09:06
 
Создайте книгу новую, а не копируйте один лист, ни или присвойте переменной, после копирования активную книгу, а далее перемещайте.
Изменено: Nordheim - 14.12.2018 16:09:06
"Все гениальное просто, а все простое гениально!!!"
 
Цитата
tsutse написал:Макрос - да, рабочий
Тогда пара вопросов. 1) Что такое Sheets(wsC)? и2) Зачем используете With ws2?
"Все гениальное просто, а все простое гениально!!!"
 
tsutse, вместо того, чтобы ответить на заданные Вам вопросы, Вы создаёте новую тему. Зачем?!!
 
Юрий М, эту тему бы удалить, а ту что закрыта открыть))

Тут я не разобрался с созданием книги...
 
Здесь Вам уже отвечали. Советы могут пригодиться другим.
 
tsutse, а отвечать на заданные вопросы не нужно? Вам ведь их задают не ради праздного любопытства.
 
Юрий М, я не настолько хорошо знаю код, что бы сразу ответить, а сообщения на 2 странице обычно уже никто не читает...
 
Но если Вы ответите, тема поднимется наверх. Да и проявить уважение к помогающему - разве это не нужно?
 
Цитата
tsutse написал:
сообщения на 2 странице обычно уже никто не читает
Ваше сообщение ещё на первой странице. А ответить на вопрос - элементарная вежливость. И вообще нужно отписываться в своих темах. Последнее сообщение должно быть Вашим. Люди тратят своё время на помощь Вам, а Вам трудно потратить минуту?
 
Немного подправил, только не получается копировать лист в созданную книгу....
Код
Sub qwe()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Integer, lr As Integer, w As String


Set ws1 = ThisWorkbook.Worksheets("ТТ")
Set ws2 = ThisWorkbook.Worksheets("МСК")
Set ws3 = ThisWorkbook.Worksheets("Back")


w = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
    
    Workbooks.Add (1)
        With ActiveWorkbook
            .SaveAs Filename:=ThisWorkbook.Path & "\МСК " & w & ".xls"
            '.Close True
        End With

lr = ws1.Cells(Rows.Count, 4).End(xlUp).Row
With ws2
For i = 9 To lr
    If ws1.Cells(i, 2) <> "" Then
    ws2.Copy , after:=ActiveWorkbook.Sheets(1) 'Вот в этом месте не пойму как правильно копировать лист
    
       
    
    wsC = Sheets.Count
    Sheets(wsC).Name = ws1.Cells(i, 2)
    Sheets(wsC).Cells(6, 43) = ws1.Cells(2, 16)
    Sheets(wsC).Cells(6, 1) = ws1.Cells(i, 6)
    Sheets(wsC).Cells(10, 1) = ws1.Cells(i, 14)
    Sheets(wsC).Cells(6, 23) = ws1.Cells(4, 16)
    
      
    End If
Next i

End With
Application.ScreenUpdating = True
End Sub
 
Итак, начнем с начала, Вы хотите сохранять листы, в коде же всего один лист копируется, отсюда вопросы. Как должно все выглядеть в итоге?  Какие листы нужно переносить?
В одну книгу или в разные?
"Все гениальное просто, а все простое гениально!!!"
 
Вот этот код переносит листы в другую книгу сохраняет ее и закрывает
Код
Sub test()
    Dim sht, book As Workbook
    Dim arr(), iPath$
    iPath = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
    iPath = ThisWorkbook.Path & "\МСК " & iPath & ".xls"
    arr = Array("TT", "МСК", "Back")
    Set book = Workbooks.Add(1)
    book.SaveAs Filename:=iPath
    For Each sht In arr
        With ThisWorkbook.Worksheets(sht)
            .Copy after:=book.Worksheets(book.Sheets.Count)
            'какое-то копирование
        End With
    Next sht
    book.Close True
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, там цикл.

В идеале должно быть что-то похожее:

По кнопке создается книга, макрос бежит по определенному столбцу и ищет непустые строки, когда он находит первую непустую строку -  копируется лист "МСК" в новую книгу, заполняется значениями из начальной таблицы, потом ищет след. непустую строку и так далее, наполняя заполненными бланками новую книгу.
Изменено: tsutse - 15.12.2018 07:29:17
 
Я Вам показал код, полностью соответствующий названию темы и вопросу и самого первого сообщения, там ни о каких данных и "бегущих" макросах речи не было .
Цитата
tsutse написал:Помогите доработать этот макрос, что б он сохранял листы в новую книгу, а не в текущую.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, значит выразился я не так
Страницы: 1
Наверх