Tell me more ×
Stack Overflow is a question and answer site for professional and enthusiast programmers. It's 100% free, no registration required.
up vote 0 down vote favorite

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
share|improve this question
What method are you using to copy the sheets to the new file? – Alistair Weir Apr 29 at 11:43
For each sheet in the first books I check if the name match an array. If yes I use the method .copy . – lmorin Apr 29 at 12:01
1  
Add your existing code to your question – Alistair Weir Apr 29 at 12:03
2  
try disabling calculation, events, and screenupdating before running the macro, and re-enable them afterwards ... If Excel is recalulating it has to take all new possible data into account – Philip Apr 29 at 14:04

2 Answers

up vote 0 down vote

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.

share|improve this answer
up vote 4 down vote

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
share|improve this answer
value2, is this a typo ? – lmorin Apr 30 at 14:37
Rub-time error '1004' Application-defined or Object-defined error on the line: .cells =x – lmorin Apr 30 at 14:51
No value2 is not a typo it is a slightly quicker path to get the value of a cell. – Marshall Apr 30 at 15:56
I found the problem @ .Cells=x. I will edit the code above to handle the issue. – Marshall Apr 30 at 16:18
ok, it works, but it doesn't keep the format... how would you adress that ? – lmorin Apr 30 at 16:37

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.