Hi I am trying to run some code that assigns a combobox a value from a single cell in a range of cells and then executes some formulas on my worksheet and then finally prints a pdf of the output sheet. Everything seems to be working ok, except that the final pdf does not display the value I am running in the combobox (although the sheet calculations have been applied). It may be that my loop executes faster than my combobox can display the value. I'm not really sure. Below is my code:
Application.ScreenUpdating = False
Dim i As Long
Dim ws As Worksheet
Dim FileName As String
Set ws = Sheets("Multi")
Set wsEE = Sheets("Employee")
FileName = ws.Range("B2")
LastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
For i = 7 To LastRow
wsEE.ComboBox4.Value = ws.Range("A" & i)
wsEE.Activate
Application.Calculate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=ws.Range("B2") & "TCC Analysis - " & ws.Range("A" & i) & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
Next i
ws.Activate
Application.ScreenUpdating = True
I also have some code that runs on combobox change. I'm not sure if this could also be part of my problem. Here is that code:
Private Sub ComboBox4_Change()
Sheets("Employee").Range("AZ1") = ComboBox4.Value
Application.Calculate
Application.DisplayAlerts = False
Dim ws As Worksheet
Set ws = Worksheets("Employee")
If Me.ComboBox4 <> -1 Then
ws.Range("C72").Value = ws.Range("C16").Value
ws.Range("C73").Value = ws.Range("C19").Value
End If
Application.Calculate
Application.DisplayAlerts = True
End Sub
Has anyone experienced this problem before? Does anyone have a solution they can provide? Thank you!
Related
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.
My code is working perfectly in debug mode. I step through every single line, and it outputs exactly how I expect. However, when it runs on open, like i want it to, it doesn't execute the last 2-3 lines properly. I put a note where it stops in the code snip below. I am a very amateur coder, so please forgive the toddler level organization and efficiency. Any and all critiques or suggestions are welcome, I am really just figuring this out as i go.
Private Sub Workbook_Open()
'Message asks user if they want to update
Dim Answer As VbMsgBoxResult
Answer = MsgBox("Would you like to update the part HS database for your tracker?" & vbCrLf & "(It will take a hot minute)", vbYesNo + vbDefaultButton2, "Update Part DB")
'if check for running the subroutine
If Answer = vbYes Then
''Turn off screen updating
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Open parser
Workbooks.Open Filename:="K:\04_Classification\Broker Templates\BrokerPartsListParser.xlsb", ReadOnly:=True
'Setting Range Variables
Dim RgData As Range
Dim RgCriteria As Range
Dim RgOutput As Range
Set RgData = Workbooks("BrokerPartsListParser.xlsb").Worksheets("NewestIPExtract").Range("A1").CurrentRegion
Set RgCriteria = ThisWorkbook.Worksheets("PartDBRef").Range("J1").CurrentRegion
Set RgOutput = ThisWorkbook.Worksheets("PartDBRef").Range("A3").CurrentRegion
'Clearing previous data
RgOutput.Offset(1).ClearContents
'Doing the Advanced Filter
RgData.AdvancedFilter xlFilterCopy, RgCriteria, RgOutput
'Check to see if ACE data needs to be pulled
Dim ACEPull As Boolean: ACEPull = ThisWorkbook.Worksheets("ACE Data").Range("AO2")
If ACEPull = True Then
'setting pulled date
ThisWorkbook.Worksheets("ACE Data").Range("AK2").Value = Date
'Finding last row of old data set
Dim LastRow As Long: LastRow = ThisWorkbook.Worksheets("ACE Data").Range("AA" & Rows.Count).End(xlUp).Row
'Deleting old Data
If IsEmpty(Range("AA2").Value) = False Then
ThisWorkbook.Worksheets("ACE Data").Range("A2:AA" & LastRow).ClearContents
End If
'Setting Advanced Filter Parameters
Set RgData = Workbooks("BrokerPartsListParser.xlsb").Worksheets("Unified ACE Data").Range("A1").CurrentRegion
Set RgCriteria = ThisWorkbook.Worksheets("ACE Data").Range("AH1").CurrentRegion
Set RgOutput = ThisWorkbook.Worksheets("ACE Data").Range("A1:AA1")
'Doing the Advanced Filter
RgData.AdvancedFilter xlFilterCopy, RgCriteria, RgOutput
''THIS IS WHERE MY CODE STOPS WORKING AS I WOULD EXPECT
'Finding New Last Row
LastRow = ThisWorkbook.Worksheets("ACE Data").Range("AA" & Rows.Count).End(xlUp).Row
'Filling Formulas
If IsEmpty(Range("AA3").Value) = False Then
ThisWorkbook.Worksheets("ACE Data").Range("AB2:AD" & LastRow).FillDown
End If
End If
''close parser
Workbooks("BrokerPartsListParser.xlsb").Close SaveChanges:=False
''Turn updating back on
Application.ScreenUpdating = True
Application.DisplayAlerts = True
''Thank people for their patience
MsgBox "Part DB has been updated. Thank you for your patience :D"
Exit Sub
Else
Exit Sub
End If
End Sub
To reiterate JvdV's comment you have an implicit range reference.Try adding the workbook and worksheet referenced to the IsEmpty statement.
'Filling Formulas
If IsEmpty(ThisWorkbook.Worksheets("ACE Data").Range("AA3").Value) = False Then
ThisWorkbook.Worksheets("ACE Data").Range("AB2:AD" & LastRow).FillDown
End If
``
The VBA code I have has worked perfectly on two other machines and with several other worksheets without the data reappearing. I've created a macro that takes a master spreadsheet and creates a new spreadsheet for each school listed in the table. I just got a new laptop and installed Excel 365 on it. I copied the VBA code to the new machine, but when I ran it, each new worksheet still contained the data for all the schools, not just the school for that particular file. I stepped through the code, and the schools did delete, but when it got to the part where the filter was removed from the table ws.ListObjects("Data").AutoFilter.ShowAllData, all the deleted rows reappeared. I'm stumped on why this is happening - It didn't happen on the other two machines and other iterations of the file that I've used this macro on. I don't know if it's an Excel setting or a setting on this particular master file. The other two machines - one used Excel 365, and the other Excel 2016. The data is not part of PowerPivot and is not a PowerQuery, so the data only lives in the table in the worksheet.
Here is the macro:
Dim i As Integer, wb As Workbook, schools() As Variant, schools_to_delete() As Variant
Dim ws As Worksheet, rng As Range, dt As String
schools = SchoolsInList()
dt = MonthName(Month(Now)) & " " & Year(Now)
Set wb = ActiveWorkbook
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
For i = 1 To UBound(schools)
wb.SaveCopyAs ("Galileo " & dt & " " & schools(i) & ".xlsx")
Workbooks.Open ("Galileo " & dt & " " & schools(i) & ".xlsx")
Workbooks("Galileo " & dt & " " & schools(i) & ".xlsx").Activate
Set ws = Sheets("Data")
ws.Activate
schools_to_delete = schools
schools_to_delete(i) = "x"
Set rng = ws.ListObjects("Data").DataBodyRange
With ws
.AutoFilterMode = False
ws.ListObjects("Data").Range.AutoFilter Field:=18, Criteria1:= _
Array(schools_to_delete), Operator:=xlFilterValues
ws.Range(rng.Address).SpecialCells(xlCellTypeVisible).Delete
.AutoFilterMode = False
ws.ListObjects("Data").AutoFilter.ShowAllData
End With
ActiveWorkbook.RefreshAll
Call SelectA1
ActiveWorkbook.Save
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub
Function SchoolsInList() As Variant
Dim schools() As String
Dim C As Collection
Dim r As Range
Dim i As Long
Dim last_row As Long
last_row = Cells(Rows.Count, 1).End(xlUp).Row
Set C = New Collection
On Error Resume Next
For Each r In Worksheets("Data").Range("R2:R" & last_row).Cells
C.Add r.Value, CStr(r.Value)
Next
On Error GoTo 0
ReDim A(1 To C.Count)
For i = 1 To C.Count
A(i) = C.Item(i)
Next i
SchoolsInList = A
End Function
Sub SelectA1()
Dim i As Long
For i = 1 To ActiveWorkbook.Sheets.Count
Sheets(i).Activate
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollRow = 1
Range("A1").Select
Next i
ActiveWorkbook.Worksheets(2).Activate
End Sub
I found the problem - the .AutoFilterMode = False didn't actually clear the filters that had already been placed on the table in question. The visible data WAS deleted, but the data that was filtered before the macro was run remained, and when the ws.ListObjects("Data").AutoFilter.ShowAllData ran, it cleared the previous filter, showing the rows that had been filtered before. I added the .ShowAllData code to the beginning of the With statement to avoid the same problem at a future date.
I have a VBA macro to check the existing 10 worksheets in the workbook and perform an analysis as shown below. I want to loop this code to do the analysis for 100 worksheets using For loop. I am stuck on how to combine AND condition and for loop? Help will be appreciated.
I have tried to use the for loop but failed.
Sub Mostoccurence()
'
' Mostoccurence Macro
'
'
Sheets.Add After:=ActiveSheet
Sheets("Sheet11").Select
Sheets("Sheet11").Name = "analysis"
Range("A1").Select
ActiveCell.FormulaR1C1 = _
"=AND(Sheet1!RC=1,Sheet2!RC=1,Sheet3!RC=1,Sheet4!RC=1,Sheet5!RC=1,Sheet6!RC=1,Sheet7!RC=1,Sheet8!RC=1,Sheet9!RC=1,Sheet10!RC=1)"
End Sub
Try something like this:
Option Explicit
Sub AddSheetCompare()
Dim oAnalysisSht As Worksheet
Dim oLoopSht As Worksheet
Dim lRow As Long
On Error Resume Next
Set oAnalysisSht = Worksheets("Analysis")
On Error GoTo 0
If oAnalysisSht Is Nothing Then
Set oAnalysisSht = ActiveWorkbook.Worksheets.Add(ActiveWorkbook.Worksheets(1))
oAnalysisSht.Name = "Analysis"
oAnalysisSht.Range("A1").Value = "Result of all worksheets"
oAnalysisSht.Range("A3").Value = "Worksheet Results"
End If
lRow = 3
For Each oLoopSht In Worksheets
If Not oLoopSht.Name = oAnalysisSht.Name Then
lRow = lRow + 1
oAnalysisSht.Range("A" & lRow).Formula = "='" & oLoopSht.Name & "'!A1=1"
End If
Next
oAnalysisSht.Range("A2").Formula = "=AND(A4:A" & lRow & ")"
End Sub
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