CODEWITHSUNDEEP
vbaexcel
Lucas Morin
Lucas Morin

Reputation: 398

Saving only some sheets in another Workbook

I want to use a macro to save only some predefined sheets in a new workbooks.

I use a userform to ask for the name of the new file, create it and open it, then copy and paste sheets one by one from the old to the new file.

This already take a lot of time to run, and this will get worse as I get more and more data in my sheets to copy and paste.

Is there another way to proceed ?

Here is my code:

WB2 is the old book, Ws is the worksheet in the old book, WB is the new book, Dico_export is a dictionary containing the name of sheets to be copied.

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

Upvotes: 0

Views: 960

Answers (2)

Marshall
Marshall

Reputation: 99

In order to retain the original formatting of the source worksheet use the following:

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

This will address the majority of the formatting; add additional cell properties as required.

Upvotes: 0

Marshall
Marshall

Reputation: 99

What is the tabl(i) variable?? Also, your code would run much faster if you were to implement an Array to capture the worksheet data and then copy to another workbook. Create a variable to hold the reference to the new workbook (to be copied to) and for the new worksheet to add to the new book. For each sheet that you copy add a new worksheet to the new book, setting name properties, etc. then add the existing sheet data to the array variable (use .Value2 property as it is faster) and copy it to the new sheet...

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

Upvotes: 4

Related Questions