Looping for dynamic pictures - excel

So I have created a dynamic selection list for excel using vba. see below
Below is the code
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call PanggilPhoto
End If
End Sub
Sub PanggilPhoto()
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T As String
myDir = ThisWorkbook.Path & "\"
CommodityName1 = Range("A2")
T = ".png"
Range("C15").Value = CommodityName
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=190, Top:=10, Width:=140,
Height:=90
errormessage:If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the Commodity!"
Range("A2").Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
End Sub
foto is a predefined data list in the sheet.
So the question is instead of doing it for one cell how can I create a loop of some sort to do it for multiple cells? I need it to import mulitple images on one macro run

found a solution
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Address = "$A$2" Then
Call schedules
End If
End Sub
Sub schedules()
Worksheets("Picture").Activate
Application.ScreenUpdating = False
Dim myObj
Dim Foto
Set myObj = ActiveSheet.DrawingObjects
For Each Foto In myObj
If Left(Foto.Name, 7) = "Picture" Then
Foto.Select
Foto.Delete
End If
Next
Dim CommodityName1 As String, CommodityName2 As String, T1 As String, T2 As String
Dim i As Integer, j As Integer, k As Integer
j = 0
For i = 2 To 100
myDir = "C:\Users\User\Desktop\ESTIMATING SHEETS\test\rebar shapes" & "\"
CommodityName1 = Range("A" & i)
T1 = ".png"
On Error GoTo errormessage:
ActiveSheet.Shapes.AddPicture Filename:=myDir & CommodityName1 & T1, _
linktofile:=msoFalse, savewithdocument:=msoTrue, Left:=230, Top:=j, Width:=140, Height:=80
errormessage:
If Err.Number = 1004 Then
Exit Sub
MsgBox "File does not exist." & vbCrLf & "Check the name of the rebar!"
Range("A" & i).Value = ""
Range("C10").Value = ""
End If
Application.ScreenUpdating = True
i = i + 11
j = j + 190
Next i
End Sub

Related

Excel visual basic cuestion on if statements, my second if statement doesnt work

I'm trying to make excel send automated emails when different cells get to different values, my first if statement works, which is when cell D6 goes over 400, now my next if statement doesn't work, which is when cell D7 goes over 400. I have to at least add 2 more if statements like this for cell D8 and D9. Here is the code:
Dim R As Range
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
Set R = Intersect(Range("D6"), Target)
If R Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 400 Then
Call send_mail_outlook
End If
'second part to check for
If Target.Cells.Count > 1 Then Exit Sub
Set R = Intersect(Range("D7"), Target)
If R Is Nothing Then Exit Sub
If IsNumeric(Target.Value) And Target.Value > 400 Then
Call send_mail_outlook1
End If
End Sub
Sub send_mail_outlook()
Dim x As Object
Dim y As Object
Dim z As String
Set x = CreateObject("Outlook.Application")
Set y = x.CreateItem(0)
z = "Hola!" & vbNewLine & vbNewLine & _
"xxx" & vbNewLine & _
"xx"
On Error Resume Next
With y
.To = "xxx#ss"
.cc = ""
.BCC = ""
.Subject = "xxx"
.Body = z
.Display
End With
On Error GoTo 0
Set y = Nothing
Set x = Nothing
End Sub
Sub send_mail_outlook1()
Dim x As Object
Dim y As Object
Dim z As String
Set x = CreateObject("Outlook.Application")
Set y = x.CreateItem(0)
z = "ss!" & vbNewLine & vbNewLine & _
"sss" & vbNewLine & _
"sss"
On Error Resume Next
With y
.To = "xx#ss"
.cc = ""
.BCC = ""
.Subject = "xxx"
.Body = z
.Display
End With
On Error GoTo 0
Set y = Nothing
Set x = Nothing
End Sub
Not totally clear on your use case, but something like this should work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim v
If Target.Cells.Count > 1 Then Exit Sub 'single-cell changes only...
v = Target.Value
If Len(v) = 0 Then Exit Sub 'no value entered
If IsNumeric(v) Then
If v > 400 Then
Select Case Target.Address(False, False) 'which cell was changed?
Case "D6": send_mail_outlook 'use of Call is deprecated
Case "D7": send_mail_outlook1
End Select
End If
End If
End Sub
A Worksheet Change: Send Mail
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge > 1 Then Exit Sub
ValidateAndSendMail Target
End Sub
Sub ValidateAndSendMail(ByVal Target As Range)
' Make sure that all of the arrays contain the same number of elements!
' 'VBA.' in front of 'Array' is used to ensure a zero-based array.
Dim tAddresses() As Variant: tAddresses = VBA.Array("D6", "D7", "D8", "D9")
Dim tNumbers() As Variant: tNumbers = VBA.Array(400, 400, 400, 400)
Dim tTo() As Variant: tTo = VBA.Array("xxx#ss", "xx#ss", "aa#ss", "bb#ss")
Dim tCC() As Variant: tCC = VBA.Array("", "", "", "")
Dim tBCC() As Variant: tBCC = VBA.Array("", "", "", "")
Dim tSubject() As Variant: tSubject = VBA.Array("xxx", "xxx", "xxx", "xxx")
Dim tBody() As String: ReDim tBody(0 To 3)
tBody(0) = "Hola!" & vbLf & vbLf & "xxx" & vbLf & "xx"
tBody(1) = "ss!" & vbLf & vbLf & "sss" & vbLf & "sss"
tBody(2) = "aa!" & vbLf & vbLf & "aaa" & vbLf & "aaa"
tBody(3) = "bb!" & vbLf & vbLf & "bbb" & vbLf & "bbb"
Dim tAddress As String: tAddress = Target.Address(0, 0)
Dim tIndex As Variant: tIndex = Application.Match(tAddress, tAddresses, 0)
If IsError(tIndex) Then Exit Sub ' target address not found in array
Dim tValue As Variant: tValue = Target.Value
If Not VarType(tValue) = vbDouble Then Exit Sub ' not a number
Dim tNumber As Double: tNumber = CDbl(tValue)
Dim i As Long: i = CLng(tIndex) - 1
If tNumber > tNumbers(i) Then
SendMail tTo(i), tCC(i), tBCC(i), tSubject(i), tBody(i)
End If
End Sub
Sub SendMail( _
ByVal smTo As String, _
ByVal smCC As String, _
ByVal smBCC As String, _
ByVal smSubject As String, _
ByVal smBody As String)
With CreateObject("Outlook.Application")
With .CreateItem(0)
On Error Resume Next
.To = smTo
.CC = smCC
.BCC = smBCC
.Subject = smSubject
.Body = smBody
.Display
On Error GoTo 0
End With
End With
End Sub

Delete row after application.match

I can't figure out why it is not deleting the row if the user selects no.
I even tried telling to delete a certain line in the ws but it still did not delete that row
Adding the data if it is not there works.
If it is already there the message box does pop up.
The only function that is not working is the delete.
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim ws As Worksheet, id, v, m
Dim FileName As String
Dim CurrentJob As Long
Dim CurrentRow As Variant '<--- NOTE
Dim CurrentCell As Variant
Dim iRow As Long
FileName = ThisWorkbook.Path & "\database.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
TryWriteMode book:=wBook _
, numberOfTries:=4 _
, secondsWaitAfterFailedTry:=10
' MsgBox "test", vbInformation
End If
If wBook.ReadOnly Then
MsgBox "Database is in use. Please try again later.", vbOKOnly + vbInformation, "Read-only book"
Exit Sub
End If
'Transfer the Data
id = TextBox2.Value
With wBook.Sheets("database")
Set ws = wBook.Sheets("database")
' m = Application.Match(id, ws.[B:B], 0) 'try to match an existing row
m = Application.Match(id, 5, 0)
CurrentJob = TextBox2.Value
CurrentRow = Application.Match(CurrentJob, ws.Range("B:B"), 0)
CurrentCell = ws.Cells(CurrentRow, 1)
If IsError(CurrentRow) Then
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
.Range("A" & iRow).Value = TextBox1.Value 'Cell
.Range("B" & iRow).Value = TextBox2.Value 'workorder number
.Range("C" & iRow).Value = TextBox3.Value 'product number
.Range("D" & iRow).Value = TextBox4.Value 'Work order quanity
Else
MsgBox "JOB ALREADY ASSIGNED TO " & CurrentCell & vbNewLine & "DO YOU WANT TO KEEP IT THIER ", vbYesNo
If Result = vbNo Then
ws.Rows(CurrentRow).EntireRow.Delete
End If
End If
End With
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
End Sub

Updating form responses from one sheet to another

I created a data entry form in Excel.
I would like that input to be stored in another sheet (Table format).
Code I found online and modified:
Function ValidateForm() As Boolean
SellerSKU.BackColor = vbWhite
Description.BackColor = vbWhite
ValidateForm = True
If Trim(SellerSKU.Value) = "" Then
MsgBox "SKU can't be left blank.", vbOKOnly + vbInformation, "SKU"
SellerSKU.BackColor = vbRed
SellerSKU.Activate
ValidateForm = False
ElseIf Trim(Description.Value) = "" Then
MsgBox "Description can't be left blank.", vbOKOnly + vbInformation, "Description"
Description.BackColor = vbRed
Description.Activate
ValidateForm = False
End If
End Function
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
SellerSKU.Value = ""
SellerSKU.BackColor = vbWhite
Description.Value = ""
Description.BackColor = vbWhite
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Dim iRow As Long
iRow = Sheets("Reference Sheet (Order Hist)").Range("A1048576").End(xlUp).Row + 1
If ValidateForm = True Then
With ThisWorkbook.Sheets("Reference Sheet (Order Hist)")
.Range("A" & iRow).Value = SellerSKU.Value
.Range("C" & iRow).Value = Description.Value
End With
Call Reset
Else
Application.ScreenUpdating = False
Exit Sub
End If
Application.ScreenUpdating = True
End Sub
When I hit "Enter" on the data entry form, the table on the other sheet does not get updated.
Also is it possible to clear the form every time an entry has been successfully made?
This worked for me. Re-organized and removed some of the repetition...
Private Sub CommandButton2_Click()
Dim iRow As Long, valErrors As String
valErrors = ValidationErrors() 'checks the form
If Len(valErrors) = 0 Then
'no errors - add the data
With ThisWorkbook.Worksheets("Reference Sheet (Order Hist)")
iRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("A" & iRow).Value = SellerSKU.Value
.Range("C" & iRow).Value = Description.Value
End With
ResetForm 'Call keyword is deprecated...
Else
MsgBox "One or more errors in form entries:" & vbLf & vbLf & valErrors, _
vbOKOnly + vbExclamation, "Check form data"
End If
End Sub
'check the form and return a listing of any errors
Function ValidationErrors() As String
Dim msg As String
CheckNonBlank SellerSKU, "SKU can't be left blank.", msg
CheckNonBlank Description, "Description can't be left blank.", msg
ValidationErrors = msg
End Function
'utility sub - check if a control has text, flag as error if missing,
' and add some text to the overall validation message
Sub CheckNonBlank(cntrl As Object, msgErr As String, ByRef msg As String)
Dim isErr As Boolean
isErr = Len(Trim(cntrl.Value)) = 0 'true if no content
ErrorFlag cntrl, isErr
If isErr And Len(msgErr) > 0 Then
msg = msg & IIf(Len(msg) > 0, vbLf, "") & msgErr 'append this error
End If
End Sub
Private Sub CommandButton1_Click()
ResetForm
End Sub
'clear textboxes and any error flags
Sub ResetForm()
SellerSKU.Value = ""
ErrorFlag SellerSKU, False
Description.Value = ""
ErrorFlag Description, False
End Sub
'flag a control as having a problem (pass False to second parameter to clear flag)
Sub ErrorFlag(cntrl As Object, Optional HasError As Boolean = True)
cntrl.BackColor = IIf(HasError, vbRed, vbWhite)
End Sub

Hyperlink link of the Image from userform added wont open

Hi i have userform with the all the data adds to the "VehicleRejected" Sheet from a userform however i have added an code for user to select an image from their drive and it will add the hyperlink to the cell now hyperlink wont open and error message comes up with "Cannot open the Specific file" can someone help me with the code please
Private Sub CommandButton3_Click()
On Error GoTo errHandler:
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Dim n As Long
Dim answer As String
Dim strFileName As String
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Application.EnableEvents = False
''''''''''''''''''''
n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)
TextBox65 = strFileName 'use to save URL or Link from picture
If strFileName = "False" Then
MsgBox "File Not Selected!"
Else
'load picture to Image control, using LoadPicture property
Me.Image2.Picture = LoadPicture(strFileName)
End If
sh.Unprotect "1234"
sh.Range("i" & n + 1).Value = Me.TextBox65.Value
sh.Range("i" & n + 1).Select
With ActiveSheet
.Hyperlinks.Add Anchor:=sh.Range("i" & n + 1), Address:=",TextToDisplay, """
End With
sh.Protect "1234"
MsgBox "Updated Successfully!!!", vbInformation
Unload Me
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("VehicleRejected").Activate
Worksheets("VehicleRejected").Cells(1, 3).Select
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please Contact Admin", vbCritical, "Error Message"
End Sub
i want to know if it is possible for image that uploaded on the userform which is in image2 can it be also inserted on to the sheet in column I, J, K , L on same row as the date entered with auto size adjusted.
Yes it is possible. Here is an example. I am going to insert the image in say I10 for demonstration purpose. Feel free to adapt it to suit your need.
Logic:
Get user's temp directory.
Save the image from the image control to user's temp directory using SavePicture.
Insert the image from the temp directory into relevant worksheet.
Resize as required.
Code:
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Private Sub CommandButton1_Click()
Dim ws As Worksheet
'~~> Change this to the relevant sheet
Set ws = Sheet1
Dim tempImagePath As String
tempImagePath = TempPath & "Temp.jpg"
'~~> Save the image to user's temp directory
SavePicture Image1.Picture, tempImagePath
DoEvents
'~~> Insert the image in cell say I10 and resize it
With ws.Pictures.Insert(tempImagePath)
'~~> If LockAspectRatio is set to true then Height and Width will not change
'~~> as per cell height and width
.ShapeRange.LockAspectRatio = msoFalse
.Left = ws.Range("I10").Left
.Top = ws.Range("I10").Top
.Width = ws.Range("I10").Width
.Height = ws.Range("I10").Height
End With
End Sub
Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
In Action:
Image attribution
Hi Siddharth with your code and with some other code played around, below is what i have got so far and it adds the hyperlink of the picture however file wont open or found.
Private Sub CommandButton3_Click()
On Error GoTo errHandler:
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Dim n As Long
Dim answer As String
Dim strFileName As String
Application.EnableCancelKey = xlDisabled
Application.ScreenUpdating = False
Application.EnableEvents = False
''''''''''''''''''''
n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)
TextBox65 = strFileName 'use to save URL or Link from picture
If strFileName = "False" Then
MsgBox "File Not Selected!"
Else
'load picture to Image control, using LoadPicture property
Me.Image2.Picture = LoadPicture(strFileName)
End If
sh.Unprotect "1234"
sh.Range("i" & n + 1).Value = Me.TextBox65.Value
sh.Range("i" & n + 1).Select
With ActiveSheet
.Hyperlinks.Add Anchor:=sh.Range("i" & n + 1), Address:=",TextToDisplay, """
End With
sh.Protect "1234"
MsgBox "Updated Successfully!!!", vbInformation
Unload Me
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("VehicleRejected").Activate
Worksheets("VehicleRejected").Cells(1, 3).Select
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please Contact Admin", vbCritical, "Error Message"
End Sub

VBA Set Print Area Based on Cell Reference

I put down together the following code. It basically loops through a path and converts all of the Excel workbooks into PDF.
I would like to setup the print area based on cell references. Cell C8 and D8
C8 = Column A - start of print area
D8 = Column M - end of print area
For example, I want the print area to start from column A - M. However, the current code prints everything, past column M
If settingsSheet.Range("C8").Value = vbNullString Or settingsSheet.Range("D8").Value = vbNullString Then
GoTo ABC
Else
reportColumnsAddr = settingsSheet.Range("C8").Value & ":" & settingsSheet.Range("D8").Value
Set reportSheet = Sheets(reportSheetName)
reportSheet.PageSetup.PrintArea = reportSheet.Columns(reportColumnsAddr).Address
End If
ABC:
Full code
Option Explicit
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim MinutesElapsed As String
Dim Filename As String
Dim Cell As String
Dim Counter As Long
If ThisWorkbook.Sheets("Sheet1").Range("C7").Value = vbNullString Then
MsgBox "Enter Tab Name"
Exit Sub
End If
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
MyFile = Dir(MyFolder & "\", vbReadOnly)
StartTime = Timer
Do While MyFile <> ""
DoEvents
On Error GoTo 0
Workbooks.Open Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False
Dim settingsSheet As Worksheet 'Source
Dim reportSheet As Worksheet 'To convert to PDF
Dim targetColumnsRange As Range 'feeds from source
Dim targetRowsRange As Range
Dim reportSheetName As String 'source sheet with the target's sheet name
Dim reportColumnsAddr As String
Dim reportRowsAddr As String
Dim WidthFit As String
Dim LengthFit As String
Set settingsSheet = ThisWorkbook.Worksheets("Sheet1") ' source
' Gather the report sheet's name
reportSheetName = settingsSheet.Range("C7").Value ' good
WidthFit = settingsSheet.Range("G8").Value
LengthFit = settingsSheet.Range("G9").Value
On Error Resume Next
Set reportSheet = Sheets(reportSheetName)
On Error GoTo 0
If reportSheet Is Nothing Then
MsgBox "No Sheet Named '" & reportSheetName & "' in This Workbook!"
Exit Sub
End If
If settingsSheet.Range("C8").Value = vbNullString Or settingsSheet.Range("D8").Value = vbNullString Then
GoTo ABC
Else
reportColumnsAddr = settingsSheet.Range("C8").Value & ":" & settingsSheet.Range("D8").Value
Set reportSheet = Sheets(reportSheetName)
reportSheet.PageSetup.PrintArea = reportSheet.Columns(reportColumnsAddr).Address
End If
ABC:
If WidthFit = "YES" Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
End If
If LengthFit = "YES" Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesTall = 1
End With
End If
Filename = ActiveWorkbook.Name
Cell = Replace(Filename, ".xlsx", ".PDF")
reportSheet.Select
If settingsSheet.Range("J8").Value = "Landscape" Then
reportSheet.PageSetup.Orientation = xlLandscape
Else
reportSheet.PageSetup.Orientation = xlPortrait
End If
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Cell, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=True, OpenAfterPublish:=False
Counter = Counter + 1
0
Workbooks(MyFile).Close SaveChanges:=False
MyFile = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "Successfully Converted " & Counter & " Files in " & MinutesElapsed & " minutes", vbInformation
End Sub
Your error is you have set IgnorePrintAreas:=True, _ in reportSheet.ExportAsFixedFormat
That said, there are many other issues in your code:
Implicit ActiveWorkbook references
Unnecessary repetition of code in the loop
Case sensitive tests
Misleading variable names
Unnecessary use of GoTo
Malformed error handling
Could try to open non xlsx files
Incomplete checks of user Settings entry
Here's a refactor of your code
Private Sub CommandButton1_Click()
Dim MyFolder As String, MyFile As String
Dim StartTime As Double
Dim TimeElapsed As String
Dim Filename As String
Dim PdfFileName As String
Dim Counter As Long
Dim Orientation As XlPageOrientation
Dim settingsSheet As Worksheet 'Source
Dim reportSheet As Worksheet 'To convert to PDF
Dim targetColumnsRange As Range 'feeds from source
Dim targetRowsRange As Range
Dim reportSheetName As String 'source sheet with the target's sheet name
Dim reportColumnsAddr As String
Dim reportRowsAddr As String
Dim WidthFit As String
Dim LengthFit As String
Dim wb As Workbook
' Set a reference to the settings sheet
Set settingsSheet = ThisWorkbook.Worksheets("Sheet1") ' source
With settingsSheet
If .Range("C7").Value = vbNullString Then
MsgBox "Enter Tab Name"
Exit Sub
End If
If .Range("C8").Value = vbNullString Or .Range("D8").Value = vbNullString Then
MsgBox "Enter Valid Columns"
Exit Sub
End If
reportColumnsAddr = .Range("C8").Value & ":" & .Range("D8").Value
On Error Resume Next
Set targetColumnsRange = .Columns(reportColumnsAddr)
On Error GoTo 0
If targetColumnsRange Is Nothing Then
MsgBox "Enter Valid Columns"
Exit Sub
End If
Set targetColumnsRange = Nothing
reportSheetName = .Range("C7").Value ' good
WidthFit = .Range("G8").Value
LengthFit = .Range("G9").Value
Orientation = IIf(StrComp(.Range("J8").Value, "Landscape", vbTextCompare) = 0, xlLandscape, xlPortrait)
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select a Folder"
If .Show = True Then
MyFolder = .SelectedItems(1)
End If
If .SelectedItems.Count = 0 Then Exit Sub
Err.Clear
End With
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
Application.Calculation = xlCalculationAutomatic
MyFile = Dir(MyFolder & "\*.xlsx", vbReadOnly)
StartTime = Timer()
Do While MyFile <> ""
DoEvents
On Error Resume Next
Set wb = Workbooks.Open(Filename:=MyFolder & "\" & MyFile, UpdateLinks:=False)
On Error GoTo 0
If wb Is Nothing Then
MsgBox "Failed to open " & MyFolder & "\" & MyFile
GoTo CleanUp
End If
Set reportSheet = Nothing
On Error Resume Next
Set reportSheet = wb.Worksheets(reportSheetName)
On Error GoTo 0
If reportSheet Is Nothing Then
MsgBox "No Sheet Named '" & reportSheetName & "' in This Workbook!"
GoTo CleanUp
End If
reportSheet.PageSetup.PrintArea = reportColumnsAddr
If StrComp(WidthFit, "YES", vbTextCompare) = 0 Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesWide = 1
End With
End If
If StrComp(LengthFit, "YES", vbTextCompare) = 0 Then
With reportSheet.PageSetup
.Zoom = False
.FitToPagesTall = 1
End With
End If
PdfFileName = Replace(wb.Name, ".xlsx", ".PDF")
reportSheet.PageSetup.Orientation = Orientation
reportSheet.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=ThisWorkbook.Path & "\" & PdfFileName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Counter = Counter + 1
wb.Close SaveChanges:=False
MyFile = Dir
Loop
CleanUp:
On Error Resume Next
wb.Close False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
TimeElapsed = Format((Timer() - StartTime) / 86400, "hh:mm:ss")
MsgBox "Successfully Converted " & Counter & " Files in " & TimeElapsed, vbInformation
End Sub

Resources