Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 851
  • Last Modified:

How do I create a macro to format the same column width for thousands of workbooks in a folder?

I ran a VBA macro that created new workbooks based on unique values from a specified column. It named and saved them all in one folder, which was amazing, but it didn't carry over the column width formatting from the original document. I am wondering what the best way is to achieve the end result. Is there a way to add in the column width formatting into the same VBA macro that creates the new workbooks...OR...should I do the column width formatting after running that macro on the folder full of new workbooks with a new macro?

There is another piece to the end result needed that may affect the solution for this. I also added a Header in Print Preview. Is there a way to add this to the either the "create new workbooks based on unique value" macro or a new macro that sets the column width for the few thousands of workbooks in the folder?

I attached the macro that I am using. Thanks in advance for any help with this.

0
jahwalk
Asked:
jahwalk
  • 5
  • 3
1 Solution
 
Patrick MatthewsCommented:
Hello jahwalk,

Please post your original code.  It should be possible to format each workbook as it is created.

Regards,

Patrick
0
 
jahwalkAuthor Commented:
Thanks Patrick. I had posted it in the attach code snippet but it doesn't appear that it went through. Also do you need the column width measurements or can you just use it from the original workbook? Here is the code:


Sub Copy_To_Workbooks()
    Dim CalcMode As Long
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim WSNew As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim Lrow As Long
    Dim foldername As String
    Dim MyPath As String
    Dim FieldNum As Integer
    Dim FileExtStr As String
    Dim FileFormatNum As Long

    'Name of the sheet with your data
    Set ws1 = Sheets("Sheet1")  '<<< Change

    'Determine the Excel version and file extension/format
    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007
        If ws1.Parent.FileFormat = 56 Then
            FileExtStr = ".xls": FileFormatNum = 56
        Else
            FileExtStr = ".xlsx": FileFormatNum = 51
        End If
    End If

    'Set filter range : A1 is the top left cell of your filter range and
    'the header of the first column, D is the last column in the filter range
    Set rng = ws1.Range("A1:X" & Rows.Count)

    'Set Field number of the filter column
    'This example filters on the first field in the range(change the field if needed)
    'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
    FieldNum = 6

    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    ' Add worksheet to copy/Paste the unique list
    Set ws2 = Worksheets.Add

    'Fill in the path\folder where you want the new folder with the files
    'you can use also this "C:\Users\Ron\test"
    MyPath = Application.DefaultFilePath

    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If

    'Create folder for the new files
    foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
    MkDir foldername

    With ws2
        'first we copy the Unique data from the filter field to ws2
        rng.Columns(FieldNum).AdvancedFilter _
                Action:=xlFilterCopy, _
                CopyToRange:=.Range("A1"), Unique:=True

        'loop through the unique list in ws2 and filter/copy to a new workbook
        Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each cell In .Range("A2:A" & Lrow)

            'Add new workbook with one sheet
            Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

            'Firstly, remove the AutoFilter
            ws1.AutoFilterMode = False

            'Filter the range
            rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

            'Copy the visible data and use PasteSpecial to paste to the new worksheet
            ws1.AutoFilter.Range.Copy
            With WSNew.Range("A1")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With

            'Save the file in the new folder and close it
            WSNew.Parent.SaveAs foldername & cell.Value & " " & "DPD" & " " & "License" & " " & "Request" & " " & "02192009" & FileExtStr, FileFormatNum
            WSNew.Parent.Close False

            'Close AutoFilter
            ws1.AutoFilterMode = False

        Next cell

        'Delete the ws2 sheet
        On Error Resume Next
        Application.DisplayAlerts = False
        .Delete
        Application.DisplayAlerts = True
        On Error GoTo 0

    End With

    MsgBox "Look in " & foldername & " for the files"

    With Application
        .ScreenUpdating = True
        .Calculation = CalcMode
    End With
End Sub

0
 
Patrick MatthewsCommented:
Without getting into splicing this into the original code, a snippet like this will "transfer" the column widths:



For Counter = 1 To OriginalWs.UsedRange.Columns.Count
    NewWs.Columns(Counter).ColumnWidth = OriginalWs.Columns(Counter).ColumnWidth
Next
0
Configuration Guide and Best Practices

Read the guide to learn how to orchestrate Data ONTAP, create application-consistent backups and enable fast recovery from NetApp storage snapshots. Version 9.5 also contains performance and scalability enhancements to meet the needs of the largest enterprise environments.

 
jahwalkAuthor Commented:
Thanks for your help Patrick. I don't know VBA well enough to understand where I should splice your additional code into the original code. Would you be able to explain this? Also will this retain the Header added in the Print Preview section?
0
 
jahwalkAuthor Commented:
I get an error when I insert your code into the original code:

Run-time error '424':
Object required


Below is where I inserted the code in the original code:

'Filter the range
            rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

            For Counter = 1 To OriginalWs.UsedRange.Columns.Count
            NewWs.Columns(Counter).ColumnWidth = OriginalWs.Columns(Counter).ColumnWidth
            Next

            'Copy the visible data and use PasteSpecial to paste to the new worksheet
            ws1.AutoFilter.Range.Copy
            With WSNew.Range("A1")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
0
 
jahwalkAuthor Commented:
I apologize, I discovered that it is formatting the column widths with Paste Special Paste:=8

But...it isn't carrying over the formatting in the Print Preview section. The layout in the new workbooks default to Portrait mode. Sorry for the confusion. Would you know how to build in the macro to carry over the landscape mode for Print Preview in the new workbooks?
0
 
Patrick MatthewsCommented:
This should bring in the column widths and page setup:




            rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

            For Counter = 1 To ws1.UsedRange.Columns.Count
                WSNew.Columns(Counter).ColumnWidth = ws1.Columns(Counter).ColumnWidth
            Next
            With WSNew.PageSetup
                .PrintTitleRows = "$1:$1" 'change as needed
                .Orientation = xlLandscape
            End With

            'Copy the visible data and use PasteSpecial to paste to the new worksheet
            ws1.AutoFilter.Range.Copy
            With WSNew.Range("A1")
                ' Paste:=8 will copy the columnwidth in Excel 2000 and higher
                .PasteSpecial Paste:=8
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
                .Select
            End With
0
 
jahwalkAuthor Commented:
Thanks for your help Patrick.
0

Featured Post

 [eBook] Windows Nano Server

Download this FREE eBook and learn all you need to get started with Windows Nano Server, including deployment options, remote management
and troubleshooting tips and tricks

  • 5
  • 3
Tackle projects and never again get stuck behind a technical roadblock.
Join Now