PDA

View Full Version : VBA code to prompt user to select file folder but still keep the file name...



mulan571
06-03-2016, 09:13 AM
Hello :hi:

I created a vba so I can select several files to print into separate pdf forms and automatically save them to a specific folder. Is there a way I can code it differently so another person can use the file and have the ability to change the file path and still able to print in batches and keep the file names?

Here is a copy of the code I'm using:

Sub PrintUsingDatabase()
Dim FormWks As Worksheet
Dim DataWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim iCtr As Long
Dim myCustomer As Variant

Set FormWks = Worksheets("2016 VRI Form")
Set Form4T = Worksheets("2016 4T Form")
Set FormSC = Worksheets("2016 SC Form")
Set DataWks = Worksheets("2016 VRI Data")

myCustomer = Array("A6")

With DataWks
'first row of data to last row of data in column D
Set myRng = .Range("E5", .Cells(.Rows.Count, "E").End(xlUp))
End With

For Each myCell In myRng.Cells
With myCell
'if the row is not marked, do nothing
If IsEmpty(.Offset(0, -3)) Then

'if print 4 tier customer
ElseIf InStr(.Offset(0, -4), "4T") Then
.Offset(0, -3).ClearContents 'clear mark for the next time
For iCtr = LBound(myCustomer) To UBound(myCustomer)
Form4T.Range(myCustomer(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate


Form4T.ExportAsFixedFormat Type:=xlTypePDF, Filename:="\\muthr\sales\Volume Rebate Calculator\VR Calculator\2016 VRI Reports\Individual PDF Files\" & myCell.Value & " " & Format(Date, "mm-dd-yyyy")

lOrders = lOrders + 1

'if print Special Customer
ElseIf InStr(.Offset(0, -4), "SC") Then
.Offset(0, -3).ClearContents 'clear makr for the next time
For iCtr = LBound(myCustomer) To UBound(myCustomer)
FormSC.Range(myCustomer(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate
FormSC.ExportAsFixedFormat Type:=xlTypePDF, Filename:="\\muthr\sales\Volume Rebate Calculator\VR Calculator\2016 VRI Reports\Individual PDF Files\" & myCell.Value & " " & Format(Date, "mm-dd-yyyy")

lOrders = lOrders + 1

'print for standard VRI form
Else
.Offset(0, -3).ClearContents 'clear mark for the next time
For iCtr = LBound(myCustomer) To UBound(myCustomer)
FormWks.Range(myCustomer(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate 'just in case

'after testing, change to Preview to False to Print
FormWks.ExportAsFixedFormat Type:=xlTypePDF, Filename:="\\muthr\sales\Volume Rebate Calculator\VR Calculator\2016 VRI Reports\Individual PDF Files\" & myCell.Value & " " & Format(Date, "mm-dd-yyyy")

lOrders = lOrders + 1
End If
End With
Next myCell

MsgBox lOrders & " orders were printed."

End Sub

Any help would be greatly appreciated! :beg:

mdmackillop
06-04-2016, 03:16 AM
Hi
Try the following. I've indicated the rows I changed. You also have undeclared variables (not fixed)

Option Explicit


Sub PrintUsingDatabase()
Dim FormWks As Worksheet
Dim DataWks As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim iCtr As Long
Dim myCustomer As Variant
Dim Pth As String


'@@@@@@@@@@@@@@@@@@@
Pth = "\\muthr\sales\Volume Rebate Calculator\VR Calculator\2016 VRI Reports\Individual PDF Files\"
Pth = BrowseForFolder(Pth)




Set FormWks = Worksheets("2016 VRI Form")
Set Form4T = Worksheets("2016 4T Form")
Set FormSC = Worksheets("2016 SC Form")
Set DataWks = Worksheets("2016 VRI Data")


myCustomer = Array("A6")


With DataWks
'first row of data to last row of data in column D
Set myRng = .Range("E5", .Cells(.Rows.Count, "E").End(xlUp))
End With


For Each myCell In myRng.Cells
With myCell
'if the row is not marked, do nothing
If IsEmpty(.Offset(0, -3)) Then


'if print 4 tier customer
ElseIf InStr(.Offset(0, -4), "4T") Then
.Offset(0, -3).ClearContents 'clear mark for the next time
For iCtr = LBound(myCustomer) To UBound(myCustomer)
Form4T.Range(myCustomer(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate


'@@@@@@@@@@@@@@@@@@@
Form4T.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Pth & myCell.Value & " " & Format(Date, "mm-dd-yyyy")


lOrders = lOrders + 1


'if print Special Customer
ElseIf InStr(.Offset(0, -4), "SC") Then
.Offset(0, -3).ClearContents 'clear makr for the next time
For iCtr = LBound(myCustomer) To UBound(myCustomer)
FormSC.Range(myCustomer(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate
'@@@@@@@@@@@@@@@@@@@
FormSC.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Pth & myCell.Value & " " & Format(Date, "mm-dd-yyyy")


lOrders = lOrders + 1


'print for standard VRI form
Else
.Offset(0, -3).ClearContents 'clear mark for the next time
For iCtr = LBound(myCustomer) To UBound(myCustomer)
FormWks.Range(myCustomer(iCtr)).Value _
= myCell.Offset(0, iCtr).Value
Next iCtr
Application.Calculate 'just in case


'after testing, change to Preview to False to Print
'@@@@@@@@@@@@@@@@@@@
FormWks.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Pth & myCell.Value & " " & Format(Date, "mm-dd-yyyy")


lOrders = lOrders + 1
End If
End With
Next myCell


MsgBox lOrders & " orders were printed."


End Sub


'http://www.vbaexpress.com/kb/getarticle.php?kb_id=284
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function

snb
06-04-2016, 05:16 AM
or ?

Sub M_snb()
With Application.FileDialog(4)
If .Show Then
c00 = .SelectedItems(1)

For Each it In Array("2016 VRI Form", "2016 4T Form", "2016 SC Form", "2016 VRI Data")
Sheets(it).ExportAsFixedFormat 0, c00 & "\" & it & ".pdf"
Next
End If
End With
End Sub