Convert Excel Sheet to PDFs, Infinite Loop Error - excel

I have used bits and pieces of code on forums to create a macro that exports PDF's from a single sheet in excel. Each PDF contains the header and all relevant rows to the employee (all rows with employee ID). When I run it all goes well and the pdfs are correct, however the macro never stops running.
I believe I have created an infinite loop and am not sure how to correct it.
It also creates a PDF just containing the header that is not necessary.
Sub PracticeToPDF()
Dim ws As Worksheet
Dim ws_unique As Worksheet
Dim DataRange As Range
Dim iLastRow As Long
Dim iLastRow_unique As Long
Dim UniqueRng As Range
Dim Cell As Range
Dim LastRow As Long
Dim LastColumn As Long
Application.ScreenUpdating = False
'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
DirectoryLocation = ActiveWorkbook.Path
Set ws = Worksheets("BootVSPayroll") 'Amend to reflect the sheet you wish to work with
Set ws_unique = Worksheets("BootVSPayroll") 'Amend to reflect the sheet you wish to work with
'Find the last row in each worksheet
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
iLastRow_unique = ws_unique.Cells(Rows.Count, "A").End(xlUp).Row
With ws
'I've set my range to reflect my headers which are fixed for this report
Set DataRange = ws.Range("$A$1:$K$1" & iLastRow)
'autofilter field is 4 as I want to print based on the practice value in column D
DataRange.AutoFilter Field:=1
Set UniqueRng = ws_unique.Range("A1:A20" & iLastRow_unique)
For Each Cell In UniqueRng
DataRange.AutoFilter Field:=1, Criteria1:=Cell
Name = DirectoryLocation & "\" & Cell.Value & " BOOT Report" & ".pdf"
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next Cell
End With
With ws
.Protect Userinterfaceonly:=True, _
DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingColumns:=True, AllowFormattingRows:=True
.EnableOutlining = True
.EnableAutoFilter = True
If .FilterMode Then
.ShowAllData
End If
End With
Application.ScreenUpdating = True
End Sub

Did you perhaps mean for:
Set DataRange = ws.Range("$A$1:$K$1" & iLastRow)
...
Set UniqueRng = ws_unique.Range("A1:A20" & iLastRow_unique)
to instead be:
Set DataRange = ws.Range("$A$1:$K$" & iLastRow)
...
Set UniqueRng = ws_unique.Range("A1:A" & iLastRow_unique)
?
If, for example, (taken from ws_unique) your last used row, iLastRow_unique equals 200, then "A1:A20" & iLastRow_unique is equivalent to "A1:A20200" -- which may be a lot more rows that you intended to loop through, I think.

Related

VBA to add data and export as excel for a list

I Have a list of data that needs to be pasted in a form in next tab and export it into PDF
Sub Mpolicy()
Dim varItemsToReplace As Variant
Dim varItem As Variant
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim rngSource As Range
Dim rngSource2 As Range
Dim rngCell As Range
Set wksSource = Worksheets("Instruction")
Set wksDest = Worksheets("Mobile Policy")
With wksSource
Set rngSource = .Range("A5:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
End With
For Each rngCell In rngSource
With wksDest
Range("A75").Formula = "=Instruction!A5"
Range("C75").Formula = "=Instruction!C5"
Range("E75").Formula = "=Instruction!B5"
Range("G75").Formula = "=Instruction!D5"
Range("A1").Select
wksDest.Activate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
"C:\Users\jkurlawala\Desktop\Master Data Template\Joby Declaration\" & ActiveSheet.Range("A75").Value & " - " & ActiveSheet.Range("C75").Value & ".pdf" _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End With
Next rngCell
End Sub
Unfortunately only 1 line of data is being copied from the list to policy form , rest of the list is not working
enter image description here
It seems as though you are trying to make a PDF for each record of the contiguous data on the sheet named "Instruction." To do that you need to put the data from one row at a time onto the sheet called "Mobile Policy," which has the policy information common to each customer. Then make a pdf of the policy with the customer data, naming according to the user's name and mobile model. If so, here is a block of code that has been simplified to accomplish just that. I've added comments to help you understand what each part is doing.
Sub Mpolicy()
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim exportPath As String
Dim exportRange As Range
Dim x As Integer
Set wksSource = Worksheets("Instruction")
Set wksDest = Worksheets("Mobile Policy")
'set the range of data to export to the block of contiguous data
'starts in cell A5 of the source worksheet
Set exportRange = wksSource.Range("A5").CurrentRegion
'iterate over the sourece data, skipping the header row
For x = 2 To exportRange.Rows.Count
'copy data from the current user to the policy sheet
exportRange.Rows(x).Copy
wksDest.Range("A75").PasteSpecial xlPasteAll
'compose the full path for the current file to export, starting
'with the path entered in cell B1 of the source worksheet
exportPath = wksSource.Range("b1").Value & _
wksDest.Range("A75").Value & " - " & _
wksDest.Range("C75").Value & ".pdf"
'make the PDF for the current row
wksDest.ExportAsFixedFormat Type:=xlTypePDF, _
filename:=exportPath, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next
End Sub

Split data across multiple workbooks depending on column value

I have a workbook that has some 100,000+ number of lead records. Each record has an agent code which determines to whom the record is allotted to(50 plus agents). What I would like to do is to distribute all lead records per agent(workbook) depending on the agent code while also maintaining the existing data formatting, data validation and also automatically creating a worksheet password. Is this possible with excel VBA?
The table runs by this sequence:
enter image description here
EDIT:
Here are some of the sample scripts we ran:
Sub ExtractToNewWorkbook()
Dim ws As Worksheet
Dim wsNew As Workbook
Dim rData As Range
Dim rfl As Range
Dim state As String
Dim sfilename As String
Set ws = ThisWorkbook.Sheets("emp")
'Apply advance filter in your sheet
With ws
Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 11).End(xlUp))
.Columns(.Columns.Count).Clear
.Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, .Columns.Count), _
Unique:=True
For Each rfl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
state = rfl.Text
Set wsNew = Workbooks.Add
sfilename = state & ".xlsx"
'Set the Location
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & sfilename
Application.DisplayAlerts = False
ws.Activate
rData.AutoFilter Field:=6, Criteria1:=state
rData.Copy
Windows(state).Activate
ActiveSheet.Paste
ActiveWorkbook.Close SaveChanges:=True
Next rfl
Application.DisplayAlerts = True
End With
ws.Columns(Columns.Count).ClearContents
rData.AutoFilter
End Sub

How to add exceptions in the creation of pdf files according to an excel list using macros

Hi I downloaded an excel file with macros that generates pdf files according to a list. There are 2 sheets and the pdf are generated from the sheet called "WEST" to generate them it uses an Autofilter function in column D so it generates a pdf for each unique value specified in the list from the sheet called "PRACTICE".
Here is the link to the file http://nhsexcel.com/filtered-list-to-pdf/
The thing is that I want to add exceptions to the code, for example I don´t want to generate pdf´s of the rows in the sheet "WEST", that contain in column i values less than 10.
I tried to add an autofilter with that criteria but the code keeps saying that it´s not a valid metod.
Sub PracticeToPDF()
'Prepared by Dr Moxie
Dim ws As Worksheet
Dim ws_unique As Worksheet
Dim DataRange As Range
Dim iLastRow As Long
Dim iLastRow_unique As Long
Dim UniqueRng As Range
Dim Cell As Range
Dim LastRow As Long
Dim LastColumn As Long
Application.ScreenUpdating = False
'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
DirectoryLocation = ActiveWorkbook.Path
Set ws = Worksheets("WEST") 'Amend to reflect the sheet you wish to work with
Set ws_unique = Worksheets("PRACTICE") 'Amend to reflect the sheet you wish to work with
'Find the last row in each worksheet
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
iLastRow_unique = ws_unique.Cells(Rows.Count, "A").End(xlUp).Row
With ws
'I've set my range to reflect my headers which are fixed for this report
Set DataRange = ws.Range("$A$8:$L$" & iLastRow)
'autofilter field is 4 as I want to print based on the practice value in column D
DataRange.AutoFilter Field:=4
Set UniqueRng = ws_unique.Range("A4:A" & iLastRow_unique)
For Each Cell In UniqueRng
DataRange.AutoFilter Field:=4, Criteria1:=Cell
Name = DirectoryLocation & "\" & Cell.Value & " Practice Report" & ".pdf"
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next Cell
End With
With ws
.Protect Userinterfaceonly:=True, _
DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingColumns:=True, AllowFormattingRows:=True
.EnableOutlining = True
.EnableAutoFilter = True
If .FilterMode Then
.ShowAllData
End If
End With
Application.ScreenUpdating = True
End Sub
I would like to just generate the pdf files of all the rows which value in column I is greater than ten, but no matter what I have tried it keeps either generating all the pdfs or not generating any at all.
I think you want an IF statement to check if there are any rows visible (excluding headers) before proceeding with the export.
That's what I do in the code below.
Option Explicit
Sub PracticeToPDF()
Dim dataSheet As Worksheet
Set dataSheet = Worksheets("WEST") 'Amend to reflect the sheet you wish to work with
Dim uniqueSheet As Worksheet
Set uniqueSheet = Worksheets("PRACTICE") 'Amend to reflect the sheet you wish to work with
'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
Dim directoryLocation As String
directoryLocation = ActiveWorkbook.Path ' Maybe you should be using Thisworkbook.Path?
If Len(Dir$(directoryLocation, vbDirectory)) = 0 Then ' Just in case the ActiveWorkbook hasn't been saved.
MsgBox "'" & directoryLocation & "' is not a valid path. Code will stop running now."
Exit Sub
End If
'Find the last row in each worksheet
Dim lastRowOnDataSheet As Long
lastRowOnDataSheet = dataSheet.Cells(dataSheet.Rows.Count, "A").End(xlUp).Row
Dim lastRowOnUniqueSheet As Long
lastRowOnUniqueSheet = uniqueSheet.Cells(uniqueSheet.Rows.Count, "A").End(xlUp).Row
'I've set my range to reflect my headers which are fixed for this report
Dim dataRange As Range
Set dataRange = dataSheet.Range("$A$8:$L$" & lastRowOnDataSheet)
Dim uniqueRange As Range
Set uniqueRange = uniqueSheet.Range("A4:A" & lastRowOnUniqueSheet)
'Application.ScreenUpdating = False ' Uncomment this when the code is working.
If dataSheet.AutoFilterMode Then
On Error Resume Next
dataSheet.ShowAllData ' Will throw if filters have already been cleared
On Error GoTo 0
End If
Dim cell As Range
For Each cell In uniqueRange
With dataRange
.AutoFilter Field:=4, Criteria1:=cell ' Filter for whatever unique value we're currently at in the loop
.AutoFilter Field:=9, Criteria1:=">10" ' Filter column I for values greater than 10
' Only export the PDF if the filter leaves at least one row (not including the header row)
If .Columns(1).SpecialCells(xlCellTypeVisible).CountLarge > 1 Then
Dim fullPathToExportPDFTo As String
fullPathToExportPDFTo = directoryLocation & "\" & cell.Value & " Practice Report" & ".pdf"
dataSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fullPathToExportPDFTo, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
.Parent.ShowAllData ' Reset the filter for the loop iteration.
End With
Next cell
With dataSheet
.Protect Userinterfaceonly:=True, DrawingObjects:=False, Contents:=True, Scenarios:=True, _
AllowFormattingColumns:=True, AllowFormattingRows:=True
.EnableOutlining = True
.EnableAutoFilter = True
End With
' Application.ScreenUpdating = True ' Uncomment this when the code is working.
End Sub

Excel VBA Macro to output multiple PDFs based on column value

I am attempting to setup a VBA macro in Excel that outputs a PDF for every set of rows with the same account number. I am tailoring this from a macro found for a similar purpose. I have two sheets, Data and Account. The Data sheet has the unfiltered data [A0, MTIME, MDATE, MINIT, MTEXT] as the row headers and the Account sheet just has the unique account numbers I want to pull.
The filtering appears to work correctly but the macro is dying at the first output component and I am a bit stumped as to why. Have verified permissions are good. Any thoughts would be apprecaited. Code Below.
Sub PracticeToPDF()
'Prepared by Dr Moxie
Dim ws As Worksheet
Dim ws_unique As Worksheet
Dim DataRange As Range
Dim iLastRow As Long
Dim iLastRow_unique As Long
Dim UniqueRng As Range
Dim Cell As Range
Dim LastRow As Long
Dim LastColumn As Long
Application.ScreenUpdating = False
'Note that the macro will save the pdf files in this active directory so you should save in an appropriate folder
DirectoryLocation = ActiveWorkbook.Path
Set ws = Worksheets("Data") 'Amend to reflect the sheet you wish to work with
Set ws_unique = Worksheets("Account") 'Amend to reflect the sheet you wish to work with
'Find the last row in each worksheet
iLastRow = ws.Cells(Rows.Count, "A").End(xlUp).Row
iLastRow_unique = ws_unique.Cells(Rows.Count, "A").End(xlUp).Row
With ws
'I've set my range to reflect my headers which are fixed for this report
Set DataRange = ws.Range("$A$1:$E$" & iLastRow)
'autofilter field is 4 as I want to print based on the practice value in column D
DataRange.AutoFilter Field:=1
Set UniqueRng = ws_unique.Range("A1:A20" & iLastRow_unique)
For Each Cell In UniqueRng
DataRange.AutoFilter Field:=1, Criteria1:=Cell
Name = DirectoryLocation & "\" & Cell.Value & " Account Notes" & ".pdf"
ws.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Next Cell
End With
With ws
.Protect Userinterfaceonly:=True, _
DrawingObjects:=False, Contents:=True, Scenarios:= _
True, AllowFormattingColumns:=True, AllowFormattingRows:=True
.EnableOutlining = True
.EnableAutoFilter = True
If .FilterMode Then
.ShowAllData
End If
End With
Application.ScreenUpdating = True
End Sub
z32a7ul put me on the right track with some items I had to correct. The ultimate issue was I had the macro built out on the sheet level and not as a module. Moved the code to the module and combined with the edits got it up and going. Thanks z32a7ul!

Creating multiple worksheets or workbooks from one source worksheet

I have a spreadsheet with over a thousand rows. The unique identifier is the vendor ID which is located in column B. The data covers from column A to column N. I want to parse this master spreadsheet and create new worksheets or better yet create a new file/workbook by each vendor ID. The spreadsheet does not contain headers. A vendor ID may just have one row or it can have 20 rows of data, 3 rows of data, etc. Lastly, I would like to convert the new file into .CSV format. When creating the new worksheets or files I would like the maintain all the formats from the source spreadsheet. The data contains, amounts, dates, and regular input of characters.
I found the below code on-line a few days ago and modified it for my needs. I was able to get it to work but I do not like how it brings over the .value and I lose the format of the dates and it creates formatting issues for the end result.
I would like to build a code flexible enough where I can modify it to create multiple worksheets within the workbook (with or without headers) or have it flexible enough where I can modify it to create workbooks based off of each vendor ID criteria (or unique criteria if it is used for other purposes). I'm trying to prevent for a user to have to create 168 files or worksheets manually based off of a consolidated worksheet.
Sub AllocatedataCSV()
Dim ws As Worksheet
Set ws = Sheets("CSV Master")
Dim LastRow As Long
LastRow = Range("B" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim rng As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set rng = Range("B1:B" & LastRow)
SeriesStart = 2
Series = Range("B" & SeriesStart)
For Each cell In rng
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
Next
' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
name As String)
Dim tgt As Worksheet
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Master List.", vbCritical, _
"Time Series Parser"
End
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
Set tgt = Sheets(name)
' copy data from src to tgt
tgt.Range("A1:N" & Last).Value = _
src.Range("A" & Start & ":N" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Worksheet
SheetExists = True
On Error Resume Next
Set ws = Sheets(name)
If ws Is Nothing Then
SheetExists = False
End If
End Function
To copy data and formatting, change:
tgt.Range("A1:N" & Last).Value = _
src.Range("A" & Start & ":N" & Last).Value
to:
src.Range("A" & Start & ":N" & Last).Copy
tgt.Range("A1").PasteSpecial xlPasteAll
To put the copied data into a new workbook:
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
name As String)
Dim wb As Workbook : Set wb = Workbooks.Add
Dim tgt As Worksheet
Set tgt = wb.Sheets(1)
tgt.name = name
src.Range("A" & Start & ":N" & Last).Copy
tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll
wb.SaveAs name
wb.Close
End Sub
UPDATE to answer question in comment
If a source series has only one row, the pasted result will be incorrect. This can be resolved by pasting onto a single cell, so
tgt.Range("A1:N" & Last).PasteSpecial xlPasteAll
becomes
tgt.Range("A1").PasteSpecial xlPasteAll
I've updated my code above to reflect this change.
This can also be resolved in the original code:
tgt.Range("A1:N" & (1+Last-Start)).Value = _
src.Range("A" & Start & ":N" & Last).Value

Resources