Сохранение только некоторых листов в другой книге

Question

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

Я использую userform, чтобы узнать имя нового файла, создать его и открыть, а затем скопировать и вставить листы один за другим из старого в новый.

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

Есть ли другой способ для продолжения?

Вот мой код:

WB2 старая книга, Ws является рабочий лист в старой книге, WB это новая книга, Dico_export представляет собой словарь, содержащий имя листов, подлежащих копированию.

For Each WS In WB2.Worksheets 
    If Dico_Export.Exists(WS.Name) Then 
     WB2.Worksheets(WS.Name).Copy after:=WB.Sheets(1 + i) 
     If WS.Name <> "Limites LPG" Then 
     tabl(i) = WS.Name 
     End If 
     i = i + 1 
    End If 
Next 

Answer 1

Что такое переменная tabl (i)? Кроме того, ваш код будет работать намного быстрее, если вы должны реализовать массив для захвата данных рабочего листа, а затем скопировать в другую книгу. Создайте переменную, чтобы сохранить ссылку на новую книгу (для ее копирования) и новый лист для добавления в новую книгу. Для каждого листа, который вы копируете, добавьте новый лист в новую книгу, установив свойства имени и т. Д., Затем добавьте существующие данные листа в переменную массива (используйте свойство .Value2, поскольку оно быстрее) и скопируйте его на новый лист. ..

Dim x() 
Dim WB As Workbook, WB2 As Workbook 
Dim newWS As Worksheet, WS As Worksheet 
Dim i As Long, r As Long, c As Long 
i = 1 

For Each WS In WB2.Worksheets 
     If Dico_Export.Exists(WS.Name) Then 
      If WS.Name <> "Limites LPG" Then 
       x = WS.Range("A1:N5000").Value2 ''need to adjust range to copy 
       Set newWS = WB.Worksheets.Add(After:=WB.Sheets(1 & i)) ''adjust to suit   your  situation 
       With newWS 
        .Name = "" '' name the worksheet in the new book 
        For r = LBound(x, 1) To UBound(x, 1) 
        For c = LBound(x, 2) To UBound(x, 2) 
         .Cells(r, c) = x(r, c) 
        Next 
        Next 
       End With 
       Erase x 
       Set newWS = Nothing 
      '' tabl(i) = WS.Name (??) 
      End If 
     End If 
Next 

Answer 2

для того, чтобы сохранить исходное форматирование исходного листа используйте следующее:

For r = LBound(x, 1) To UBound(x, 1) 
    For c = LBound(x, 2) To UBound(x, 2) 
    NewWS.Rows(r).RowHeight = WS.Cells(r, c).RowHeight 
    NewWS.Columns(c).ColumnWidth = WS.Cells(r, c).ColumnWidth 
    With NewWS.Cells(r, c) 
     .Font.Bold = WS.Cells(r, c).Font.Bold 
     .Borders(xlEdgeBottom).LineStyle = WS.Cells(r, c).Borders(xlEdgeBottom).LineStyle 
     .Borders(xlEdgeLeft).LineStyle = WS.Cells(r, c).Borders(xlEdgeLeft).LineStyle 
     .Borders(xlEdgeRight).LineStyle = WS.Cells(r, c).Borders(xlEdgeRight).LineStyle 
     .Interior.ColorIndex = WS.Cells(r, c).Interior.ColorIndex 
     .Orientation = WS.Cells(r, c).Orientation 
     .Font.Size = WS.Cells(r, c).Font.Size 
     .HorizontalAlignment = WS.Cells(r, c).HorizontalAlignment 
     .VerticalAlignment = WS.Cells(r, c).VerticalAlignment 
     .MergeCells = WS.Cells(r, c).MergeCells 
     .Font.FontStyle = WS.Cells(r, c).Font.FontStyle 
     .Font.Name = WS.Cells(r, c).Font.Name 
     .ShrinkToFit = WS.Cells(r, c).ShrinkToFit 
     .NumberFormat = WS.Cells(r, c).NumberFormat 
    End With 
    Next 
Next 

Это будет решать большинство форматирования; при необходимости добавьте дополнительные свойства ячейки.