I am working on a program that will create coversheets for projects.
All source data is held on the 'data' tab, and using lookups it is populated on the '1034' tab
Cell P2 on sheet '1034' contains the Project#, and after saving that form to PDF, should be set to the next value in the range of projects in 'data'
Below is what I have so far
Sub Generate1034()
'Select Project # Cell, set value to start
Range("P2").Value = Range(Application.Worksheets("Data").Range("A3"))
'Set range on 'data' from A3:(empty cell)
Range (Application.Worksheets("Data").Range("A3").Select)
Do Until IsEmpty(ActiveCell)
'Save Parameters
Application.Worksheets("1034").Range("P2") = Format(x, "000")
Dim SaveName As String
SaveName = ActiveSheet.Range("P33").Text
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\1034\" & _
SaveName & ".pdf"\
'Set P2 to the next value in range
Range("P2").Value = Range(Application.Worksheets("Data").Range("A3"))
Loop
End Sub
This is the previous code that it was running on, but I would like to make it a bit more flexible if the size of the range changes.
This would lookup '001' on data, and return the value from colB
Sub SaveAs()
For x = 1 To 5
Application.Worksheets("1034").Range("P2") = Format(x, "000")
Dim SaveName As String
SaveName = ActiveSheet.Range("P33").Text
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\1034\" & _
SaveName & ".pdf"
Next x
End Sub
Related
I have an excel Dashboard document where cell D1 has a dropdown of 50 rep names. When D1 changes, all data on the page changes. My code exports an individual PDF for each value in D1 and loads it to the rep's personal file on our drive. I would like to also take all 50 of these PDFs and merge them into one single PDF file for our management team to review and save it in a seperate folder. My code currently looks like this:
Sub MakeFiles()
Dim rep As String
Dim reppath As String
Dim path As String
Dim pathmanagement As String
Dim MyFileName As String
Dim myrange As Range
Dim i As Range
On Error GoTo errHandler
ActiveWorkbook.Sheets("REF").Visible = False
ActiveWorkbook.Sheets("Individual").Activate
path = "C:\Users\ph\vf\Reporting\"
pathmanagement = "C:\Users\ph\vf\Reporting\management"
Set myrange = Worksheets("REF").Range("A2", Worksheets("REF").Range("a2").End(xlDown))
For Each i In myrange
Worksheets("Individual").Range("d1").Value = i
Application.Calculate
rep = Worksheets("Individual").Range("d1").Value
ActiveWorkbook.Sheets("Individual").Activate
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=path & ActiveSheet.Range("f1").Value & "\" & ActiveSheet.Range("g1").Value & "\" & "Territory Summary" & " " & ActiveSheet.Range("e1").Value & " " & Format(DateAdd("m", -1, Date), "mmmm yyyy") & ".pdf"
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pathmanagement & "\" & "Rep Territory Summaries" & "\" & "Territory Summary" & " " & ActiveSheet.Range("e1").Value & ".pdf"
Next i
MsgBox "Done!"
Exit Sub
errHandler: MsgBox "Could not create PDF file."
End Sub
Is there something I can add to this code to also get a single PDF that will show the results of all 50 values in D1? Or if I upload copies of each file into a separate folder, is there code that will then automatically merge them into one PDF file?
Export Multiple Versions of a Worksheet to PDF
Not tested.
The following should loop through column A of Source and write each value to D1 of Destination which will generate a different version of Destination due to formulas recalculating. Then this version will be exported as PDF to two paths (initially) and it will be copied to a newly added workbook (the addition). Finally, the new workbook will be exported as PDF and closed without saving changes.
Adjust AnotherFilePath appropriately.
Option Explicit
Sub MakeFiles()
Const RepPath As String = "C:\Users\ph\vf\Reporting\"
Const ManPath As String = "C:\Users\ph\vf\Reporting\management\"
On Error GoTo errHandler
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = wb.Worksheets("Individual")
Dim sws As Worksheet: Set sws = wb.Worksheets("REF")
sws.Visible = False
' The following line assumes that the data doesn't contain any empty
' cells. Using `xlUp` is the preferred (usually safer) way.
Dim srg As Range: Set srg = sws.Range("A2", sws.Range("A2").End(xlDown))
Dim rwb As Workbook
Dim sCell As Range
Dim n As Long
For Each sCell In srg.Cells
dws.Range("D1").Value = sCell.Value
Application.Calculate
wb.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=RepPath & dws.Range("F1").Value & "\" _
& dws.Range("G1").Value & "\" & "Territory Summary" _
& " " & dws.Range("E1").Value & " " _
& Format(DateAdd("m", -1, Date), "mmmm yyyy") & ".pdf"
wb.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=ManPath & "Rep Territory Summaries" & "\" _
& "Territory Summary" & " " & dws.Range("e1").Value & ".pdf"
n = n + 1
If n = 1 Then
dws.Copy ' adds a new workbook containing only the current 'dws'
Set rwb = ActiveWorkbook
Else
dws.Copy After:=rwb.Sheets(rwb.Sheets.Count)
End If
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
Next sCell
rwb.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:="AnotherFilePath" & ".pdf"
rwb.Close False
MsgBox "Exported " & n & " worksheets.", vbInformation, "PDF Export"
ProcExit:
Exit Sub
errHandler:
MsgBox "Could not create PDF file."
Resume ProcExit
End Sub
First of all I'd like to preface this by saying that I have less than a week's experience using VBA.
I have been trying to create a script that merges PDFs that are linked in an Excel sheet. The code that I have works fine, however, when I add multiple tables separated by empty rows, the script will continue to move down through the empty cells and collect the PDFs from the next table as well.
So if I select the bottom table to merge, it will work fine, but if I select the top one, it will merge all the linked PDFs for ALL the tables moving down.
Here is a screenshot of the Excel sheet I have at the moment:
Excel Sheet
What I would like is for the script to stop at the first empty cell it encounters while moving down column D, rather than continuing until the last populated cell. Meaning that the script will only merge one table of PDFs.
As I said, this is my first week using any VBA, so I have been struggling to get the range for the PDF merging to end when it encounters the empty cell.
Any help would be greatly appreciated!
Sub Button9_Click()
'References
'Adobe Acrobat 10.0 Type Library
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim PDFfiles As Range, PDFfile As Range
Dim n As Long
Dim em As String
'Set start point of cell range
'Takes ActiveCell from search results and offsets to filepaths
'CURRENTLY LOOKS FOR LAST POPULATED CELL IN COLUMN, DISREGARDING PREVIOUS EMPTY CELLS
With ActiveSheet
Set PDFfiles = .Range(ActiveCell.Offset(3, 1), .Cells(.Rows.Count, "D").End(xlUp))
End With
'Create Acrobat API objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open first PDF file and merge other PDF files into it
n = 0
For Each PDFfile In PDFfiles
n = n + 1
If n = 1 Then
objCAcroPDDocDestination.Open PDFfile.Value
Else
objCAcroPDDocSource.Open PDFfile.Value
If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MsgBox "Error merging" & PDFfile.Value
End If
objCAcroPDDocSource.Close
End If
Next
'Save merged PDF files as a new file
objCAcroPDDocDestination.Save 1, "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
'Opens dialogue box for successful/failed merge
MsgBox "Created New PDF (" & Sheets("SEARCH").Range("E6").Value & ")" & vbCrLf & vbCrLf & "File Path: C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
'Opens merged PDF
ActiveWorkbook.FollowHyperlink "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
End Sub
Try the next code, please:
Sub MergePDFDocuments()
'References to 'Adobe Acrobat 10.0 Type Library
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc, objCAcroPDDocSource As Acrobat.CAcroPDDoc, i As Long
Dim PDFfiles As Range, PDFfile As Range, n As Long, em As String, processArr As String, prRng As Range
Dim sh As Worksheet, startRow As Long, endRow As Long
Set sh = ActiveSheet 'use here your sheet
processArr = "A" 'the group files to be processed.
'It can be "B", or other letter if the workbook will be filled with other groups
'CURRENTLY LOOKS FOR LAST POPULATED CELL IN COLUMN, DISREGARDING PREVIOUS EMPTY CELLS
'Set PDFfiles = sh.Range(sh.Offset(3, 1), sh.cells(rows.count, "D").End(xlUp))
endRow = sh.cells(rows.count, "D").End(xlUp).row
For i = 2 To endRow
If sh.Range("C" & i).value = "PRODUCT " & processArr Then
startRow = i + 2: Exit For
End If
Next i
If startRow >= i Then MsgBox "Strange..." & vbCrLf & _
"The area to be prcessed ""PRODUCT " & processArr & """ could not be found.": Exit Sub
'Create Acrobat API objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open first PDF file and merge other PDF files into it
For i = startRow To endRow
n = n + 1
If sh.Range("D" & i).value = "" Then Exit For 'iteration is interrupted in case of an empty cell in D:D:
If n = 1 Then
objCAcroPDDocDestination.Open sh.Range("D" & i).value
Else
objCAcroPDDocSource.Open sh.Range("D" & i).value
If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, _
objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MsgBox "Error merging: " & sh.Range("D" & i).value
End If
objCAcroPDDocSource.Close
End If
Next i
'Save merged PDF files as a new file. Here the pdf name can be assorted with the area to be processed (for instance PRODUCT A):
objCAcroPDDocDestination.Save 1, "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
'Opens dialogue box for successful/failed merge
MsgBox "Created New PDF (" & Sheets("SEARCH").Range("E6").value & ")" & vbCrLf & vbCrLf & "File Path: C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
'Opens merged PDF
ActiveWorkbook.FollowHyperlink "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
End Sub
You must set processArr to be processed (A or B from your picture).
Code is not tested, but it should work. Please test it and send some feedback.
EDIT
I got it to run thru about 1,000 part numbers, but now it stops and excel freezes. Is it possibly too much for excel to handle? Would it be better to add a filter and have user perform this task based off criteria xyz?
I'm using the following code to create a mass form replacement. It's intended to run through a list of 5000+ part numbers, paste the part number into a designated range on another worksheet where it creates the form and saves it as a pdf in a specified folder. It works up until row 105 and then stops. It does what it's supposed to, other than continue down the sheet. I have the same code (modified slightly) being used on another sheet and it runs perfect. I'm not sure why its stopping after a certain number of rows
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
Dim x As Worksheet
Dim y As Worksheet
Dim i As Long
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 3 To FinalRow
Set x = ThisWorkbook.Worksheets("Part Number Database")
Set y = ThisWorkbook.Worksheets("BOM")
x.Cells(i, 1).Copy Destination:=y.Range("E3:J3")
strFile = Range("E3") & ".pdf"
strPathFile = strPath & strFile
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\AGoodwin\Desktop\BOM\" & strFile & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next i
MsgBox "PDF file has been created: " _
& vbCrLf _
& myFile
End Sub
my actual code is :
Option Explicit
Sub SaveMailActiveSheetAsPDFIn2016()
'Ron de Bruin : 1-May-2016
'Test macro to save/mail the Activesheet as pdf with ExportAsFixedFormat with Mail
Dim FileName As String
Dim FolderName As String
Dim Folderstring As String
Dim FilePathName As String
Dim strbody As String
'Check for AppleScriptTask script file that we must use to create the mail
If CheckAppleScriptTaskExcelScriptFile(ScriptFileName:="RDBMacMail.scpt") = False Then
MsgBox "Sorry the RDBMacMail.scpt is not in the correct location"
Exit Sub
End If
'My example sheet is landscape, I must attach this line
'for making the PDF also landscape, seems to default to
'xlPortait the first time you run the code
ActiveSheet.PageSetup.Orientation = xlLandscape
'Name of the folder in the Office folder
FolderName = "TempPDFFolder"
'Name of the pdf file
FileName = "Order " & [C1] & " " & Format(Date, "dd-mm-yyyy") & ".pdf"
Folderstring = CreateFolderinMacOffice2016(NameFolder:=FolderName)
FilePathName = Folderstring & Application.PathSeparator & FileName
'Create the body text in the strbody string
strbody = "Hi " & [C2] & "," & vbNewLine & vbNewLine & _
"Please find attached our new order" & vbNewLine & _
vbNewLine & _
"Thanks"
'expression A variable that represents a Workbook, Sheet, Chart, or Range object.
'Not working if you change activeworkbook, always save the activesheet
'Also the parameters are not working like in Windows
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
FilePathName, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False
'Call the MacExcel2016WithMacMailPDF function to save the new pdf and create the mail
'When you use more mail addresses separate them with a ,
'Look in Mail>Preferences for the name of the mail account or signature
'Account name looks like this : "Your Name <your#mailaddress.com>"
MacExcel2016WithMacMailPDF subject:=[C6] & Format(Date, "dd/mm/yy"), _
mailbody:=strbody, _
toaddress:=[C3], _
ccaddress:=[C4], _
bccaddress:=[C5], _
attachment:=FilePathName, _
displaymail:=True, _
thesignature:="", _
thesender:=""
End Sub
I would like that all cells from E column in the print area =0 not to be displayed and that the sheet shrinks itself (like deleting the lines were =0), this before creating the .pdf document and opening mailbox.
I dunno if I'm clear enough sorry
Thank you for your help though
Assuming column E of Sheet1 is the one you want to hide if filled with zeros:
Sub hideZeroFilledColumn()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("E:E")
rng.EntireColumn.Hidden = (Excel.WorksheetFunction.Count(rng) = _
Excel.WorksheetFunction.CountIf(rng, "0"))
End Sub
Or, if you want to hide just the lines when cell value in column E:E is 0:
Sub hideLineWithZero()
Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets("Sheet1")
Dim strColumn As String
strColumn = "E" 'If the column you want to check is "E:E"
'Getting first row of printarea and setting "rngPrintStart" to that row in column strColumn
Dim rngPrintStart As Range
'The split is used to separate the start and end of the PrintArea address
'Here we take component "0" of the split, so the start part of the PrintArea
Set rngPrintStart = Range(Split(WS.PageSetup.PrintArea, ":")(0))
Set rngPrintStart = WS.Range(strColumn & rngPrintStart.Row)
'Getting last row of printarea and setting "rngPrintEnd" to that row in column strColumn
Dim rngPrintEnd As Range
'The split is used to seperate the start and end of the PrintArea address
'Here we take component "1" of the split, so the end part of the PrintArea
Set rngPrintEnd = Range(Split(WS.PageSetup.PrintArea, ":")(1))
Set rngPrintEnd = WS.Range(strColumn & rngPrintEnd.Row)
'Merging rngPrintStart and rngPrintEnd ranges from printarea in column strColumn
Dim rngPrintColumnE As Range
Set rngPrintColumnE = WS.Range(rngPrintStart, rngPrintEnd)
Dim rng As Range
Dim rngToHide As Range
'looking in all cells from rngPrintColumnE
For Each rng In rngPrintColumnE
'checking if cell value is equal to 0 and is not empty
If (rng.Value2 = 0) And (rng.Value2 <> "") Then
'Building the range to be hidden
If rngToHide Is Nothing Then 'For the first time when "rngToHide" is not yet set
Set rngToHide = rng
Else
Set rngToHide = Union(rngToHide, rng)
End If
End If
Next rng
'to hide the rows from the previously built range
rngToHide.Rows.EntireRow.Hidden = True
End Sub
I'm assuming you want to hide column E if all the values in it are zero?
Do a sum of the values into another cell (X99 in my example) then use the following code:
With ActiveSheet
If .Range("X99").Value = 0 Then
.Range("e:e").EntireColumn.Hidden = True
Else
.Range("e:e").EntireColumn.Hidden = False
End If
End With
Edit:
You can use Abs(Min(E:E))>0 instead of Sum if you have negative values
For some reason I can't add another answer so here goes with another edit.
To hide rows that have zero in the e column:
Dim i As Integer
Dim pa As Range
Dim ecolnumber As Integer
ecolnumber = 5
Set pa = Range(ActiveSheet.PageSetup.PrintArea)
For i = 0 To pa.Rows.Count
Dim ecell As Range
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = ecell.Value = 0
Next
Note the ecolnumber, you may have to change it to reference the correct column.
After you have done all your stuff you can unhide the rows with:
For i = 0 To pa.Rows.Count
Set ecell = pa(i, ecolnumber)
ecell.EntireRow.Hidden = False
Next
I'm trying to create something to read data from a .txt file, then populate data into .xls, but after open the .txt file, how do I get the data out? Basically I'm trying to get the the third column of the lines dated '04/06/2010'. After I open the .txt file, when I use ActiveSheet.Cells(row, col), the ActiveSheet is not pointing to .txt file.
My .txt file is like this (space delimited):
04/05/10 23 29226
04/05/10 24 26942
04/06/10 1 23166
04/06/10 2 22072
04/06/10 3 21583
04/06/10 4 21390
Here is the code I have:
Dim BidDate As Date
BidDate = '4/6/2010'
Workbooks.OpenText Filename:=ForecastFile, StartRow:=1, DataType:=xlDelimited, Space:=True
If Err.Number = 1004 Then
MsgBox ("The forecast file " & ForecastFile & " was not found.")
Exit Sub
End If
On Error GoTo 0
Dim row As Integer, col As Integer
row = 1
col = 1
cell_value = activeSheet.Cells(row, col)
MsgBox ("the cell_value=" & cell_value)
Do While (cell_value <> BidDate) And (cell_value <> "")
row = row + 1
cell_value = activeSheet.Cells(row, col)
' MsgBox ("the value is " & cell_value)
Loop
If cell_value = "" Then
MsgBox ("A load forecast for " & BidDate & " was not found in your current load forecast file titled '" + ForecastFile + ". " + "Make sure you have a load forecast for the current bid date and then open this spreadsheet again.")
ActiveWindow.Close
Exit Sub
End If
Can anyone point out where it goes wrong here?
In the example below, I set the variable ws equal to the sheet I want and I'm able to use that variable to refer to the sheet later. The keyword ActiveWorkbook should point to the newly opened text file. I could tell what you wanted to do with the info, such I just made some stuff up.
Sub GetBidData()
Dim dtBid As Date
Dim ws As Worksheet
Dim rFound As Range
Dim sFile As String
dtBid = #4/6/2010#
sFile = Environ("USERPROFILE") & "\My Documents\ForecastFile.txt"
Workbooks.OpenText Filename:=sFile, _
StartRow:=1, _
DataType:=xlDelimited, _
Space:=True
Set ws = ActiveWorkbook.Sheets(1)
Set rFound = ws.Columns(1).Find( _
Format(dtBid, ws.Range("A1").NumberFormat), , xlValues, xlWhole)
If Not rFound Is Nothing Then
MsgBox rFound.Value & vbCrLf & _
rFound.Offset(0, 1).Value & vbCrLf & _
rFound.Offset(0, 2).Value
End If
End Sub
You should generally avoid using the ActiveWorkbook object unless you're positive that the workbook you want to reference will always be active when your code is run. Instead, you should set the workbook you're working with to a variable. Theoretically, you should be able to use the OpenText method to do this, but VBA doesn't like that. (I'm pretty sure it's a bug.) So right after you open your text file, I would do this:
Workbooks.OpenText Filename:=Forecastfile, StartRow:=1,
DataType:=xlDelimited, Space:=True
Dim ForecastWorkbook As Workbook, book As Workbook
Dim ForecastFileName As String
ForecastFileName = "YourFileNameHere.txt"
For Each book In Application.Workbooks
If book.Name = ForecastFileName Then
Set ForecastWorkbook = book
Exit For
End If
Next book
Then, instead of this...
cell_value = activeSheet.Cells(row, col)
...do this...
cell_value = ForecastWorkbook.Sheets(1).Cells(row, col).Value
Below code will read the text file and paste the values in the cell of Sheet2. However if you put a formatting in the Date column that will do the trick
Public Sub Read_text()
Sheet2.Activate
Set fso = New FileSystemObject
Fname = Application.GetOpenFilename
x = 1
y = 1
Set Stream = fso.OpenTextFile(Fname, ForReading, True)
Do While Not Stream.AtEndOfStream
Str_text = Stream.ReadLine 'Perform your actions
rdtext = Split(Str_text, " ")
Sheet2.Cells(x, y) = rdtext(0)
Sheet2.Cells(x, y + 1) = rdtext(1)
Sheet2.Cells(x, y + 2) = rdtext(2)
x = x + 1
y = 1
Loop
Stream.Close
End Sub
For example : Below code will change the format in '05/04/2010'
Sheet2.Cells(x, y) = Format(rdtext(0), "mm/dd/yyyy;#")