Auto save multiple accounts from one sheet - Simplify

tlc53

tlc53

Active Member
Joined
Jul 26, 2018
Messages
399
Hi,

I'm wondering if there's an easier way to do this, which is user friendly and can cope with new accounts being added. Currently I have the below code, which works great. However, I have 100 accounts and the below code is for just 3 accounts. It is going to be very time consuming writing all that code and then if a new account is added, I would need to add new code for it.

This is how it currently works.
I have a sheet called "Dashboard". From here, you can automatically save each individual account by checking a command button (hence where below code comes in). There are approximately 100 sheets which relate to each account. I have named these in the format letter-letter-letter-number-number eg. ABC01
Currently the sheet/account name is hardwired into the code. Is it possible for it to recognise the sheet name by a cell reference on the "Dashboard"? This is located in column A.
Also, the ActiveX command button is located on the same row (column J) it needs to obtain all it's information from.
The first one for eg, AAI001
A12 = AAI001 (sheet/account name)
M12 = File save path
N12 = File save name
J12 = Checkbox to run code
L12 = Cell to confirm when file saved

On my dashboard at the bottom of the table I have allocated 10 spaces for any new accounts to be added. I have pre-populated the account names from ZZZ01 to ZZZ10

Is there a more condensed way to write this code and maybe for it to understand it should get its data from the same row the command button is on (perhaps it needs to be a form control rather than an ActiveX).

Thank you!



Code: 
Private Sub CheckBox1_Click()
  If CheckBox1 Then
    Call SavePdf1("AAI01")
    CheckBox1.Value = True
  End If
End Sub


Sub SavePdf1(wSheet As String)
  Dim wfolder As String, wfile As String
  wfolder = Range("M12").Value
  wfile = Range("N12").Value
  If wfolder = "" Then
    MsgBox "Enter folder"
    Exit Sub
  End If
  If wfile = "" Then
    MsgBox "Enter file name"
    Exit Sub
  End If
  If Dir(wfolder, vbDirectory) = "" Then
    MsgBox "Folder does not exists"
    Exit Sub
  End If
  If Right(wfolder, 1) <> "\" Then wfolder = wfolder & "\"
  If Right(wfile, 4) <> ".pdf" Then wfile = wfile & ".pdf"
  Sheets(wSheet).ExportAsFixedFormat Type:=xlTypePDF, Filename:=wfolder & wfile, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  MsgBox "The file has been saved"
  CheckBox1.Enabled = False
  Range("L12").Value = "Saved " & Date
End Sub


Private Sub CheckBox2_Click()
  If CheckBox2 Then
    Call SavePdf2("ADI01")
    CheckBox2.Value = True
  End If
End Sub


Sub SavePdf2(wSheet As String)
  Dim wfolder As String, wfile As String
  wfolder = Range("M13").Value
  wfile = Range("N13").Value
  If wfolder = "" Then
    MsgBox "Enter folder"
    Exit Sub
  End If
  If wfile = "" Then
    MsgBox "Enter file name"
    Exit Sub
  End If
  If Dir(wfolder, vbDirectory) = "" Then
    MsgBox "Folder does not exists"
    Exit Sub
  End If
  If Right(wfolder, 1) <> "\" Then wfolder = wfolder & "\"
  If Right(wfile, 4) <> ".pdf" Then wfile = wfile & ".pdf"
  Sheets(wSheet).ExportAsFixedFormat Type:=xlTypePDF, Filename:=wfolder & wfile, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  MsgBox "The file has been saved"
  CheckBox1.Enabled = False
  Range("L13").Value = "Saved " & Date
End Sub


Private Sub CheckBox3_Click()
  If CheckBox3 Then
    Call SavePdf3("ADI02")
    CheckBox3.Value = True
  End If
End Sub


Sub SavePdf3(wSheet As String)
  Dim wfolder As String, wfile As String
  wfolder = Rangen("M14").Value
  wfile = Range("N14").Value
  If wfolder = "" Then
    MsgBox "Enter folder"
    Exit Sub
  End If
  If wfile = "" Then
    MsgBox "Enter file name"
    Exit Sub
  End If
  If Dir(wfolder, vbDirectory) = "" Then
    MsgBox "Folder does not exists"
    Exit Sub
  End If
  If Right(wfolder, 1) <> "\" Then wfolder = wfolder & "\"
  If Right(wfile, 4) <> ".pdf" Then wfile = wfile & ".pdf"
  Sheets(wSheet).ExportAsFixedFormat Type:=xlTypePDF, Filename:=wfolder & wfile, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  MsgBox "The file has been saved"
  CheckBox1.Enabled = False
  Range("L14").Value = "Saved " & Date
End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
Sort by date Sort by votes
I did not test this because I did not want to set up a bunch of files to process, but step through the code on a COPY of your workbook to see how it works.
Let me know if any problems arise.

Code: 
Option Explicit

'I chose not to use command buttons since you would have to create 100 (or more of them)
'If that is a requirement the code can be modfied

'Dashboard'    layout (partial)
'Column        Header      Description
'--------      ----------- ------------------------------------------------
'Column A/1    Account     sheet/account name
'Column J/10   Flag        If any text in this columnm, process that row
'Column M/13   Folder      Folder associated with the account
'Column N/14   File        FileNameExt associated with the account
'Column L/12   Saved       indicates file saved (or red if save fails)

'Put any text in the column J cell for that row to processed

'Run the 'ProcessMain' code

Sub ProcessMain()

    Dim lLastRow As Long
    Dim lRowIndex As Long
    
    ValidateFileAndFolderNames
    
    With Worksheets("Dashboard")
        lLastRow = .Cells(.Rows.Count, 10).End(xlUp).Row    'Last filled cell in column A
        
        For lRowIndex = 2 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Passing arguments to subroutine
                SavePDF .Cells(lRowIndex, "A").Value, .Cells(lRowIndex, "M").Value, .Cells(lRowIndex, "N").Value, lRowIndex
            End If
        Next
    End With
            
End Sub

Sub ValidateFileAndFolderNames()
    'For all rows with column J text
    '  Verify folder exists
    '  Verify FileNameExt exists, DOES NOT verify it is a valid FileNameExt
    
    Dim lLastRow As Long
    Dim lLastFilledRow As Long
    Dim lRowIndex As Long
    Dim lErrorCount As Long
    
    With Worksheets("Dashboard")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row             'Last filled cell in column A (accounts)
        lLastFilledRow = .Cells(.Rows.Count, 10).End(xlUp).Row      'Last filled cell in column J (action flag)
        
        'Clear color indicator
        'Note: (Cells(R,C) format can use either column number or letter for its column (C) argument)
        .Range(.Cells(2, "M"), .Cells(lLastRow, 14)).Interior.Color = xlNone    'Clear color from columns M:N
        
        For lRowIndex = 2 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Column J not blank, so process its row
                If .Cells(lRowIndex, 14).Value = vbNullString Then
                    'No FileNameExt
                    .Cells(lRowIndex, 14).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                If Dir(.Cells(lRowIndex, 13).Value, vbDirectory) < 3 Then  'Dir of <null> returns "."; Shortest folder name is C:\
                    'Specified folder does not exist
                    .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
            End If
        Next
    End With
    
    If lErrorCount > 0 Then
        MsgBox "Column M & N have been shaded yellow where there is a missing FileNameExt or " & _
            "invalid folder name. " & vbLf & vbLf & _
            "Correct these problems then rerun code.", vbCritical, "Missing or Invalid Entries"
        End
    End If
    
End Sub

Sub SavePDF(sAccount As String, sFolderName As String, sFileNameExt As String, lRow As Long)

    If Right(sFolderName, 1) <> "\" Then sFolderName = sFolderName & "\"
    If UCase(Right(sFileNameExt, 4)) <> ".PDF" Then sFileNameExt = sFileNameExt & ".pdf"
    
    Sheets(sAccount).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolderName & sFileNameExt, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
    If Err.Number <> 0 Then
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = rgbRed
        'Left column J/10 populated
    Else
        Worksheets("Dashboard").Cells(lRow, 10).Value = vbNullString        'Flag Column(J)
        Worksheets("Dashboard").Cells(lRow, 12).Value = "Saved " & Date     'Saved Column (L)
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = xlNone 'In case it was red at start of code
    End If
    
End Sub
 
Upvote 0
pbornemeier said:
I did not test this because I did not want to set up a bunch of files to process, but step through the code on a COPY of your workbook to see how it works.
Let me know if any problems arise.
<null>
Click to expand...

Thank you for this! I wasn't sure if this was going to be possible, so I spent yesterday writing out each section of code 110 times. It took a very long time :)
I tried your code out however, it didn't seem to work. I think it's because I have an ActiveX checkbox in column J, so it's not actually IN column J but on it. However, I did try just adding text to column J to see if that would initiate your code. No such luck I'm afraid.
Not sure what I'm doing wrong? Any ideas please?</null>
 
Upvote 0
Corrected error. Try it again.

If you have to copy sections of code multiple times (110 !!!!) there is almost always an easier way to perform that function.

Code: 
Option Explicit

'I chose not to use command buttons since you would have to create 100 (or more of them)
'If that is a requirement the code can be modfied

'Dashboard'    layout (partial)
'Column        Header      Description
'--------      ----------- ------------------------------------------------
'Column A/1    Account     sheet/account name
'Column J/10   Flag        If any text in this columnm, process that row
'Column M/13   Folder      Folder associated with the account
'Column N/14   File        FileNameExt associated with the account
'Column L/12   Saved       indicates file saved (or red if save fails)

'Put any text in the column J cell for that row to processed

'Run the 'ProcessMain' code

'#############################################
'If PDF already exists, it will be overwritten
'#############################################

Sub ProcessMain()

    Dim lLastRow As Long
    Dim lRowIndex As Long
    
    ValidateFileAndFolderNames
    
    With Worksheets("Dashboard")
        lLastRow = .Cells(.Rows.Count, 10).End(xlUp).Row    'Last filled cell in column A
        
        For lRowIndex = 2 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Passing arguments to subroutine
                SavePDF .Cells(lRowIndex, "A").Value, .Cells(lRowIndex, "M").Value, .Cells(lRowIndex, "N").Value, lRowIndex
            End If
        Next
    End With
            
End Sub

Sub ValidateFileAndFolderNames()
    'For all rows with column J text
    '  Verify folder exists
    '  Verify FileNameExt exists, DOES NOT verify it is a valid FileNameExt
    
    Dim lLastRow As Long
    Dim lLastFilledRow As Long
    Dim lRowIndex As Long
    Dim lErrorCount As Long
    Dim sFolder As String
    Dim sRetVal As String
    
    With Worksheets("Dashboard")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row             'Last filled cell in column A (accounts)
        lLastFilledRow = .Cells(.Rows.Count, 10).End(xlUp).Row      'Last filled cell in column J (action flag)
        
        'Clear color indicator
        'Note: (Cells(R,C) format can use either column number or letter for its column (C) argument)
        .Range(.Cells(2, "M"), .Cells(lLastRow, 14)).Interior.Color = xlNone    'Clear color from columns M:N
        .Range(.Cells(2, 1), .Cells(lLastRow, 1)).Interior.Color = xlNone    'Clear color from column A
        
        For lRowIndex = 2 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Column J not blank, so process its row
                'Check for presence of file name
                If .Cells(lRowIndex, 14).Value = vbNullString Then
                    'No FileNameExt
                    .Cells(lRowIndex, 14).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                'Check for valid folder
                sFolder = .Cells(lRowIndex, 13).Value
                If sFolder <> vbNullString Then
                    If Len(Dir(sFolder, vbDirectory)) < 3 Then 'Dir of <null> returns "."; Shortest folder name is C:\
                        'Specified folder does not exist
                        .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                        lErrorCount = lErrorCount + 1
                    End If
                Else
                    'Folder cell is blank
                    .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                'Check that account worksheet exists
                On Error Resume Next
                sRetVal = Worksheets(.Cells(lRowIndex, 1).Value).Range("A1").Value  'Error if folder does not exist
                If Err.Number <> 0 Then
                    .Cells(lRowIndex, 1).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                On Error GoTo 0
            End If
        Next
    End With
    
    If lErrorCount > 0 Then
        MsgBox "Columna A, M & N have been shaded yellow where there is a missing or " & _
            "invalid values. " & vbLf & vbLf & _
            "Correct these problems then rerun code.", vbCritical, "Missing or Invalid Entries"
        End
    End If
    
End Sub

Sub SavePDF(sAccount As String, sFolderName As String, sFileNameExt As String, lRow As Long)

    If Right(sFolderName, 1) <> "\" Then sFolderName = sFolderName & "\"
    If UCase(Right(sFileNameExt, 4)) <> ".PDF" Then sFileNameExt = sFileNameExt & ".pdf"
    
    Sheets(sAccount).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolderName & sFileNameExt, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
    If Err.Number <> 0 Then
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = rgbRed
        'Left column J/10 populated
    Else
        Worksheets("Dashboard").Cells(lRow, 10).Value = vbNullString        'Flag Column(J)
        Worksheets("Dashboard").Cells(lRow, 12).Value = "Saved " & Date     'Saved Column (L)
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = xlNone     'In case it was red at start of code
    End If
    
End Sub
 
Upvote 0
pbornemeier said:
Corrected error. Try it again.

If you have to copy sections of code multiple times (110 !!!!) there is almost always an easier way to perform that function.

<null>
Click to expand...

Thanks. Row 11 has the headings for my table, Row 12 is the first line of data, finishing at Row 121.

I put the word "save" in cells A12, A13 and A15.

I ran the Process Main code. It highlighted cells;
- A6, M6, N6
- A11, M11
- M12
- M13
- M15

I am not sure why it is highlighting the last 3, as the file path looks fine and exists (eg. c:\Users\Documents\Test Files\). The other cells highlighted, it appears the code is looking above the range.


</null>
 
Upvote 0
I did not notice your headers started in row 11. Also added a few reporting lines. Try revised code.

Code: 
Option Explicit

'I chose not to use command buttons since you would have to create 100 (or more of them)
'If that is a requirement the code can be modfied

'Dashboard'    layout (partial)
'Column        Header      Description
'--------      ----------- ------------------------------------------------
'Column A/1    Account     sheet/account name
'Column J/10   Flag        If any text in this column, process that row
'Column M/13   Folder      Folder associated with the account
'Column N/14   File        FileNameExt associated with the account
'Column L/12   Saved       indicates file saved (or red if save fails)

'Row 11 contains headings, data starts row 12

'Put any text in the column J cell for that row to processed

'Run the 'ProcessMain' code

'#############################################
'If PDF already exists, it will be overwritten
'#############################################

Sub ProcessMain()

    Dim lLastRow As Long
    Dim lLastARow As Long
    Dim lLastJRow As Long
    Dim lRowIndex As Long
    Dim lBadSave As Long
    Dim lGoodSave As Long
    Dim sOutput As String
    Dim lJMarks As Long
    
    ValidateFileAndFolderNames
    
    With Worksheets("Dashboard")
    
        'Determine last row that needs to be checked
        lLastARow = .Cells(.Rows.Count, 1).End(xlUp).Row    'Last filled cell in column A
        lLastJRow = .Cells(.Rows.Count, 10).End(xlUp).Row    'Last filled cell in column A
        lLastRow = lLastJRow
        If lLastARow < lLastRow Then lLastRow = lLastARow
        lJMarks = Application.WorksheetFunction.CountA(.Range("J12:J" & lLastRow))
        
        For lRowIndex = 12 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Passing arguments to subroutine
                SavePDF .Cells(lRowIndex, "A").Value, .Cells(lRowIndex, "M").Value, .Cells(lRowIndex, "N").Value, lRowIndex
                If .Cells(lRowIndex, 12).Interior.Color = rgbRed Then
                    lBadSave = lBadSave + 1
                Else
                    lGoodSave = lGoodSave + 1
                End If
            End If
        Next
        
        .Range("A11:N" & lLastRow).Columns.AutoFit
    End With

    If lJMarks > 0 Then
        If lGoodSave > 0 Then sOutput = lGoodSave & " documents saved.  " & _
            "Their column J cleared, their column L is updated." & vbLf
        If lBadSave > 0 Then sOutput = sOutput & lBadSave & _
            " documents could not be saved and are tinted red in column L, " & _
            "their column J is unmodified." & vbLf
        MsgBox sOutput, , "Processing Report"
    Else
        MsgBox "No rows marked in column J", , "Nothing Processed"
    End If
    
End Sub

Sub ValidateFileAndFolderNames()
    'For all rows with column J text
    '  Verify folder exists
    '  Verify FileNameExt exists, DOES NOT verify it is a valid FileNameExt
    
    Dim lLastRow As Long
    Dim lLastFilledRow As Long
    Dim lRowIndex As Long
    Dim lErrorCount As Long
    Dim sFolder As String
    Dim sRetVal As String
    
    With Worksheets("Dashboard")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row             'Last filled cell in column A (accounts)
        lLastFilledRow = .Cells(.Rows.Count, 10).End(xlUp).Row      'Last filled cell in column J (action flag)
        
        'Clear color indicator
        'Note: (Cells(R,C) format can use either column number or letter for its column (C) argument)
        .Range(.Cells(12, "M"), .Cells(lLastRow, 14)).Interior.Color = xlNone    'Clear color from columns M12:Nxx
        .Range(.Cells(12, 1), .Cells(lLastRow, 1)).Interior.Color = xlNone    'Clear color from column A12:Axx
        
        For lRowIndex = 12 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Column J not blank, so process its row
                'Check for presence of file name
                If .Cells(lRowIndex, 14).Value = vbNullString Then
                    'No FileNameExt
                    .Cells(lRowIndex, 14).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                'Check for valid folder
                sFolder = .Cells(lRowIndex, 13).Value
                If sFolder <> vbNullString Then
                    If Len(Dir(sFolder, vbDirectory)) < 3 Then 'Dir of  returns "."; Shortest folder name is C:\
                        'Specified folder does not exist
                        .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                        lErrorCount = lErrorCount + 1
                    End If
                Else
                    'Folder cell is blank
                    .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                'Check that account worksheet exists
                On Error Resume Next
                sRetVal = Worksheets(.Cells(lRowIndex, 1).Value).Range("A1").Value  'Error if folder does not exist
                If Err.Number <> 0 Then
                    .Cells(lRowIndex, 1).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                On Error GoTo 0
            End If
        Next
    End With
    
    If lErrorCount > 0 Then
        MsgBox "Columna A, M & N have been shaded yellow where there is a missing or " & _
            "invalid values. " & vbLf & vbLf & _
            "Correct these problems then rerun code.", vbCritical, "Missing or Invalid Entries"
        End
    End If
    
End Sub

Sub SavePDF(sAccount As String, sFolderName As String, sFileNameExt As String, lRow As Long)

    If Right(sFolderName, 1) <> "\" Then sFolderName = sFolderName & "\"
    If UCase(Right(sFileNameExt, 4)) <> ".PDF" Then sFileNameExt = sFileNameExt & ".pdf"
    
    On Error Resume Next
    Sheets(sAccount).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolderName & sFileNameExt, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
    If Err.Number <> 0 Then
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = rgbRed
        'Left column J/10 populated
    Else
        Worksheets("Dashboard").Cells(lRow, 10).Value = vbNullString        'Flag Column(J)
        Worksheets("Dashboard").Cells(lRow, 12).Value = "Saved " & Date     'Saved Column (L)
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = xlNone     'In case it was red at start of code
    End If
    On Error GoTo 0
    
End Sub
 
Upvote 0
Solution
pbornemeier said:
I did not notice your headers started in row 11. Also added a few reporting lines. Try revised code.
Click to expand...

I've tried this out and so far, it's working great. Thank you!! It works better than my 110x code :)
I'm now going to roll it out on my main template. I'll let you know how it goes..
 
Upvote 0
pbornemeier said:
I did not notice your headers started in row 11. Also added a few reporting lines. Try revised code.
Click to expand...

Hi. This is working great but there is one strange thing. Once it's saved the files, it resizes my columns. Perhaps to auto-fit.

I tried determining the column widths at the bottom of the code, but that hasn't worked. Any idea please?? Thanks.

Code: 
Option Explicit


'Dashboard'    layout (partial)
'Column        Header      Description
'--------      ----------- ------------------------------------------------
'Column A/1    Account     sheet/account name
'Column J/10   Flag        If any text in this column, process that row
'Column M/13   Folder      Folder associated with the account
'Column N/14   File        FileNameExt associated with the account
'Column L/12   Saved       indicates file saved (or red if save fails)


'Row 11 contains headings, data starts row 12


'Put any text in the column J cell for that row to processed


'Run the 'ProcessMain' code


'#############################################
'If PDF already exists, it will be overwritten
'#############################################


Sub ProcessMain()


    Dim lLastRow As Long
    Dim lLastARow As Long
    Dim lLastJRow As Long
    Dim lRowIndex As Long
    Dim lBadSave As Long
    Dim lGoodSave As Long
    Dim sOutput As String
    Dim lJMarks As Long
    
    ValidateFileAndFolderNames
    
    With Worksheets("Dashboard")
    
        'Determine last row that needs to be checked
        lLastARow = .Cells(.Rows.Count, 1).End(xlUp).Row    'Last filled cell in column A
        lLastJRow = .Cells(.Rows.Count, 10).End(xlUp).Row    'Last filled cell in column A
        lLastRow = lLastJRow
        If lLastARow < lLastRow Then lLastRow = lLastARow
        lJMarks = Application.WorksheetFunction.CountA(.Range("J12:J" & lLastRow))
        
        For lRowIndex = 12 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Passing arguments to subroutine
                SavePDF .Cells(lRowIndex, "A").Value, .Cells(lRowIndex, "M").Value, .Cells(lRowIndex, "N").Value, lRowIndex
                If .Cells(lRowIndex, 12).Interior.Color = rgbRed Then
                    lBadSave = lBadSave + 1
                Else
                    lGoodSave = lGoodSave + 1
                End If
            End If
        Next
        
        .Range("A11:N" & lLastRow).Columns.AutoFit
    End With


    If lJMarks > 0 Then
        If lGoodSave > 0 Then sOutput = lGoodSave & " documents saved,  " & _
            "as noted in column L." & vbLf
        If lBadSave > 0 Then sOutput = sOutput & lBadSave & _
            " documents could not be saved and are tinted red in column L, " & _
            "their column J is unmodified." & vbLf
        MsgBox sOutput, , "Processing Report"
    Else
        MsgBox "No rows marked in column J", , "Nothing Processed"
    End If
    
End Sub


Sub ValidateFileAndFolderNames()
    'For all rows with column J text
    '  Verify folder exists
    '  Verify FileNameExt exists, DOES NOT verify it is a valid FileNameExt
    
    Dim lLastRow As Long
    Dim lLastFilledRow As Long
    Dim lRowIndex As Long
    Dim lErrorCount As Long
    Dim sFolder As String
    Dim sRetVal As String
    
    With Worksheets("Dashboard")
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row             'Last filled cell in column A (accounts)
        lLastFilledRow = .Cells(.Rows.Count, 10).End(xlUp).Row      'Last filled cell in column J (action flag)
        
        'Clear color indicator
        'Note: (Cells(R,C) format can use either column number or letter for its column (C) argument)
        .Range(.Cells(12, "M"), .Cells(lLastRow, 14)).Interior.Color = xlNone    'Clear color from columns M12:Nxx
        .Range(.Cells(12, 1), .Cells(lLastRow, 1)).Interior.Color = xlNone    'Clear color from column A12:Axx
        
        For lRowIndex = 12 To lLastRow
            If .Cells(lRowIndex, 10).Value <> vbNullString Then
                'Column J not blank, so process its row
                'Check for presence of file name
                If .Cells(lRowIndex, 14).Value = vbNullString Then
                    'No FileNameExt
                    .Cells(lRowIndex, 14).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                'Check for valid folder
                sFolder = .Cells(lRowIndex, 13).Value
                If sFolder <> vbNullString Then
                    If Len(Dir(sFolder, vbDirectory)) < 3 Then 'Dir of  returns "."; Shortest folder name is C:\
                        'Specified folder does not exist
                        .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                        lErrorCount = lErrorCount + 1
                    End If
                Else
                    'Folder cell is blank
                    .Cells(lRowIndex, 13).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                'Check that account worksheet exists
                On Error Resume Next
                sRetVal = Worksheets(.Cells(lRowIndex, 1).Value).Range("A1").Value  'Error if folder does not exist
                If Err.Number <> 0 Then
                    .Cells(lRowIndex, 1).Interior.Color = rgbYellow
                    lErrorCount = lErrorCount + 1
                End If
                On Error GoTo 0
            End If
        Next
    End With
    
    If lErrorCount > 0 Then
        MsgBox "One or more file paths do not exist. Please check " & _
            "and create as necessary. " & vbLf & vbLf & _
            "Once done, press SAVE button again.", vbCritical, "Missing or Invalid Entries"
        End
    End If
    
End Sub


Sub SavePDF(sAccount As String, sFolderName As String, sFileNameExt As String, lRow As Long)


    If Right(sFolderName, 1) <> "\" Then sFolderName = sFolderName & "\"
    If UCase(Right(sFileNameExt, 4)) <> ".PDF" Then sFileNameExt = sFileNameExt & ".pdf"
    
    On Error Resume Next
    Sheets(sAccount).ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFolderName & sFileNameExt, _
        Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        
    If Err.Number <> 0 Then
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = rgbRed
        'Left column J/10 populated
    Else
        Worksheets("Dashboard").Cells(lRow, 10).Value = vbNullString        'Flag Column(J)
        Worksheets("Dashboard").Cells(lRow, 12).Value = "Saved " & Date     'Saved Column (L)
        Worksheets("Dashboard").Cells(lRow, 12).Interior.Color = xlNone     'In case it was red at start of code
    End If
    On Error GoTo 0
    
    Columns("A:A").Select
    Selection.ColumnWidth = 9
    Columns("B:C").Select
    Selection.ColumnWidth = 28
    Columns("D:D").Select
    Selection.ColumnWidth = 8
    Columns("E:E").Select
    Selection.ColumnWidth = 24.55
    Columns("F:G").Select
    Selection.ColumnWidth = 10
    Columns("H:H").Select
    Selection.ColumnWidth = 12
    Columns("I:J").Select
    Selection.ColumnWidth = 10
    Columns("I:J").Select
    Selection.ColumnWidth = 11.27
    Range("A11").Select
    
End Sub
 
Upvote 0
Glad it's working.
The .autofit line is what is setting the column widths after each save. Remove it.
Also, selecting is not necessary for most VBA actions and it slows processing a bit. Change your column setting code to:

Code: 
    Columns("A:A").ColumnWidth = 9
    Columns("B:C").ColumnWidth = 28
    Columns("D:D").ColumnWidth = 8
    Columns("E:E").ColumnWidth = 24.55
    Columns("F:G").ColumnWidth = 10
    Columns("H:H").ColumnWidth = 12
    Columns("I:J").ColumnWidth = 10
    Columns("I:J").ColumnWidth = 11.27
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question
email current sheet as macro enabled workbook
Replies
0
Views
239
lizemi
L
L
  • Question
Opening link and saving as pdf
Replies
0
Views
384
lizemi
L
L
  • Solved
Send Email VBA
Replies
1
Views
439
DanteAmor
DanteAmor
L
  • Question
Authorising Purchase Orders
Replies
4
Views
395
lizemi
L
M
  • Question
Excel VBA Save PDF within workbook folder and send as email attachment
Replies
1
Views
191
rpaulson
rpaulson

Forum statistics

Threads
1,214,412
Messages
6,119,365
Members
448,888
Latest member
Arle8907

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top