I am creating a template, like an excel form (CATALOG) that is needed to be generated into PDF and in another sheet, must be copied to another sheet and also to be saved in an excel form. I have a generate button where my macro is. But the problem is, it keeps looping as it keeps saving infinitely. I can't find what's wrong. Hope you can help. thanks in advance! :)
Here's the code:
Sub savetopdf()
Dim FilePath As String
Dim FileName As String
Dim FileName2 As String
Dim MyDate As String
Dim client As String
Dim ref As Integer
Dim type1 As String
Dim NewBook As Workbook
Application.DisplayAlerts = False
Rows("27").EntireRow.Hidden = True
Rows("46").EntireRow.Hidden = True
Rows("47").EntireRow.Hidden = True
Rows("59").EntireRow.Hidden = True
Rows("63").EntireRow.Hidden = True
Rows("69").EntireRow.Hidden = True
Rows("78").EntireRow.Hidden = True
Rows("90").EntireRow.Hidden = True
Rows("96").EntireRow.Hidden = True
ThisWorkbook.Sheets("CATALOG").Shapes("Rounded Rectangle 3").Visible = False
FilePath = "\\10.10.19.20\2017\5. SALES OPERATIONS\4. ENTERPRISE BUSINESS
GROUP\CUSTOMER DATA BASE\Maintenance-Warranty Summary"
MyDate = Format(Date, "MM-DD-YYYY")
ref = ThisWorkbook.Sheets("CATALOG").Range("G13").Value + 1
client = ThisWorkbook.Sheets("CATALOG").Range("C5").Value
type1 = ThisWorkbook.Sheets("CATALOG").Range("C16").Value
With ThisWorkbook.Sheets("CATALOG").PageSetup
.CenterHeader = ""
.Orientation = xlPortrait
.PrintArea = "$B$2:$F$98"
.PrintTitleRows = ActiveSheet.Rows(2).Address
.Zoom = False
.FitToPagesTall = 1
.FitToPagesWide = 1
End With
FileName = FilePath & "\" & MyDate & "_" & ref & "_" & client
ThisWorkbook.Sheets("Catalog").ExportAsFixedFormat Type:=xlTypePDF,
FileName:=FileName, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=False, _
IgnorePrintAreas:=False, _
From:=1, _
To:=1, _
OpenAfterPublish:=True
FileName2 = FilePath & "\" & MyDate & "_" & ref & "_" & client
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("INVENTORY LIST").Copy Before:=NewBook.Sheets(1)
NewBook.SaveAs FileName:=FileName2, FileFormat:=xlOpenXMLWorkbook
ThisWorkbook.Sheets("CATALOG").Range("G13").Value = ref
ThisWorkbook.Save
End Sub
Related
So I am trying to print an Excel sheet. So far I got most of the stuff set up, but I can't get the line number nor the column letter working.
I tried a bunch of stuff like LineNumbering, PrintTitleColumns, but I think that's not what I am actually looking for.
Here's my code:
Sub PrintToPDF()
' Saves active sheet as PDF file.
Dim Name As String
Dim wkPrint As Worksheet
FileNameArray = Split(ThisWorkbook.Name, ".")
Name = ThisWorkbook.Path & "\" & Format(Now(), "yyyy-mm-dd") & "_" & FileNameArray(0) & ".pdf"
Set wkPrint = ThisWorkbook.Worksheets("Dokumentation")
'On Error GoTo err
'wkPrint.PrintCommunication = True
With wkPrint.PageSetup
.PaperSize = xlPaperA3
.RightHeader = "&D &T"
.PrintGridlines = True
'.LineNumbering.Active = True
'.PrintTitleColumns = "A:AA"
End With
'Application.PrintCommunication = True
wkPrint.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Name, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
Exit Sub
'err:
'MsgBox err.Description
End Sub
Thanks in advance!
You are looking for wkPrint.PageSetup.PrintHeadings = True
How do I remove the last empty line that the VBA creates when you save a sheet to a csv?
Sub SaveAsCSV()
Dim strSourceSheet As String
Dim strFullname As String
strSourceSheet = "Sheet1"
strFullname = "\\H:\filepath\filepath1\"
myfilenamedate = Format(Range("C2"), "yyyyMMdd")
myfilenameindicator = "data"
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname & myfilenameindicator & myfilenamedate & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=True, _
local:=True
ActiveWorkbook.Close
End Sub
I have updated the code to #FaneDuru's specification and when this code is expressed in this manner it still returns an error. If someone can assist it helping understand what is happening it would be much appreciated. My VBA understanding is quite limited.
Sub SaveAsCSV()
Function eliminateEmptyRow(fullName As String) As Boolean
'Necessary a reference to "Microsoft Script Control 1.0"
Dim fso As New FileSystemObject, txtStr As TextStream, objOutputFile As TextStream, strText As String
If Dir(fullName) <> "" Then 'check if file exists
Set txtStr = fso.OpenTextFile(fullName)
strText = txtStr.ReadAll
txtStr.Close
Else
eliminateEmptyRow = False: Exit Function
End If
strText = left(strText, Len(strText) - 2)
Set objOutputFile = fso.CreateTextFile(fullName)
objOutputFile.Write strText
objOutputFile.Close
eliminateEmptyRow = True
End Function
Dim strSourceSheet As String
Dim strFullname As String
strSourceSheet = "Sheet1"
strFullname = "\\H:\filepath\filepath1\"
myfilenamedate = Format(Range("C2"), "yyyyMMdd")
myfilenameindicator = "data"
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname & myfilenameindicator & myfilenamedate & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=True, _
local:=True
ActiveWorkbook.Close
If Not eliminateEmptyRow(strFullname & myfilenameindicator & myfilenamedate & ".csv") Then Stop
End Sub
Try please the next approach. Naturally Excel inserts an empty line to append if you need that. The next function should open the created file and should eliminate the VbCrLf from the end:
Function eliminateEmptyRow(fullName As String) As Boolean
'Necessary a reference to "Microsoft Script Control 1.0"
Dim fso As New FileSystemObject, txtStr As TextStream, objOutputFile As TextStream, strText As String
If Dir(fullName) <> "" Then 'check if file exists
Set txtStr = fso.OpenTextFile(fullName)
strText = txtStr.ReadAll
txtStr.Close
Else
eliminateEmptyRow = False: Exit Function
End If
strText = left(strText, Len(strText) - 2)
Set objOutputFile = fso.CreateTextFile(fullName)
objOutputFile.Write strText
objOutputFile.Close
eliminateEmptyRow = True
End Function
Insert the next line after ActiveWorkbook.Close:
If Not eliminateEmptyRow(strFullname & myfilenameindicator & myfilenamedate & ".csv") Then Stop
Test it, please and send some feedback.
Edited, to include the function call in the original code:
Sub SaveAsCSV()
Dim strSourceSheet As String
Dim strFullname As String
strSourceSheet = "Sheet1"
strFullname = "\\H:\filepath\filepath1\"
myfilenamedate = Format(Range("C2"), "yyyyMMdd")
myfilenameindicator = "data"
ThisWorkbook.Sheets(strSourceSheet).Copy
ActiveWorkbook.SaveAs Filename:=strFullname & myfilenameindicator &
myfilenamedate & ".csv", _
FileFormat:=xlCSV, _
CreateBackup:=True, _
local:=True
ActiveWorkbook.Close
If Not eliminateEmptyRow(strFullname & myfilenameindicator & myfilenamedate & ".csv") Then Stop
End Sub
How do I rename an OLEObject?
The object is embedded and the oname variable works when used in the other lines but the .name command will not work. There is no error.
Public Sub insertFiles()
Dim newObject As Object
Dim oname As String
Dim CheckName As String
CheckName = UserForm1.MultiPage2.SelectedItem.Caption
oname = CheckName & "_" & "Evidence" & "_" & UserForm1.ProjectName.Value & "_" & Format(Date, "ddmmmyyyy")
Worksheets("Emails").Activate
Range("A" & Rows.Count).End(xlUp).Offset(1).Select
Set Rng = ActiveCell
Rng.RowHeight = 70
On Error Resume Next
fpath = Application.GetOpenFilename("All Files,*.*", Title:="Select file")
If LCase(fpath) = "false" Then Exit Sub
If UserForm1.ProjectName.Value <> Empty Then
ActiveCell.Value = "."
ActiveSheet.OLEObjects.Add(Filename:=fpath, _
Link:=False, _
DisplayAsIcon:=True, _
IconFileName:="Outlook.msg", _
IconIndex:=1, _
IconLabel:=extractFileName(fpath)).Name = oname
ActiveCell.Offset(0, 1).Value = oname
UserForm1.Attached1.Value = oname
ThisWorkbook.Worksheets("Output").Range("B35").Value = oname
Call UserForm1.Tickbox
UserForm1.LablePIA.Visible = True
UserForm1.Attached1.Visible = True
UserForm1.View.Visible = True
UserForm1.Deleteemail.Visible = True
MsgBox "Attachment uploaded"
Else
MsgBox "Project Name must be input before emails can be uploaded"
End If
End Sub
Public Function extractFileName(filePath)
For i = Len(filePath) To 1 Step -1
If Mid(filePath, i, 1) = "\" Then
extractFileName = Mid(filePath, i + 1, Len(filePath) - i + 1)
Exit Function
End If
Next
End Function
Solution:
The string variable contained too many characters, apparently the max is 35.
OLEObject names cannot exceed 35 characters (presumably unless you use a class module etc!).
Try like this
Dim Obj As OLEObject
set Obj = ActiveSheet.OLEObjects.Add(Filename:=fpath, _
Link:=False, _
DisplayAsIcon:=True, _
IconFileName:="Outlook.msg", _
IconIndex:=1, _
IconLabel:=extractFileName(fpath))
Obj.name = oname
I'm new to VBA and I've been trying to create a macro where we have a list of cost centres (total of 385) and the idea behind it is to go through them one by one through a slicer. After each value was selected it will be PDFed then move to the next one. First time I ran it it worked for the first 20 then it crashed my excel, then the second time it ran 24 and crashed again, so on and so forth. The crash itself doesn't bring any error messages it just closes down excel.
I've used both with and without display alerts and screenupdate however the same result.
Any help is much appreciated.
My code below:
Sub Macro_test1()
Dim strGenericFilePath As String: strGenericFilePath = "C:\Users\"
Dim strYear As String: strYear = Year(Date) & "\"
Dim strMonth As String: strMonth = MonthName(Month(Date)) & "\"
Dim strDay As String: strDay = Format(Date, "dd.mm.yyyy") & "\"
Dim IntSliceCount As Integer
Dim IntLoop As Integer
Dim SliceLoop As Integer
Dim Slice As SlicerItem
Dim sC As SlicerCache
Set sC = ActiveWorkbook.SlicerCaches("Slicer_CostCentre")
'Application.DisplayAlerts = False
'Application.ScreenUpdating = False
'This reminds the user to only select the first slicer item
If sC.VisibleSlicerItems.Count <> 1 Or sC.SlicerItems(1).Selected = False Then
MsgBox "Please only select first cost centre from slicer in 'Summary+Air' tab"
Exit Sub
End If
For i = 1 To sC.SlicerItems.Count
'Do not clear filter as it causes to select all of the items (sC.ClearManualFilter)
sC.SlicerItems(i).Selected = True
If i <> 1 Then sC.SlicerItems(i - 1).Selected = False
'Debug.Print sI.Name
'Add export to PDF code here
With sheet1.PageSetup
.PrintArea = sheet1.Range("A1:V91" & lastRow).Address
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
sheet2.Range("F7") = sC.SlicerItems(i).Name
' Check for year folder and create if needed
If Len(Dir(strGenericFilePath & strYear, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear
End If
' Check for month folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth
End If
' Check for date folder and create if needed
If Len(Dir(strGenericFilePath & strYear & strMonth & strDay, vbDirectory)) = 0 Then
MkDir strGenericFilePath & strYear & strMonth & strDay
End If
' Save File
sheet1.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:= _
strGenericFilePath & strYear & strMonth & strDay & sheet2.Range("F7").Text & ".pdf", _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Next
'Application.DisplayAlerts = True
'Application.ScreenUpdating = True
End Sub
I am writing a function to take all the worksheets labeled "STORE #01" and create separate files for reach store that contain two tabs:
1 - The same "Compare Depts" sheet which all files will have
2 - The unique sheet associated with that store
Files must be stored as Store_01_City.xls.
When I run the macro, I do not see any files created. Also, the workbook I am running the macro in is password protected but I have entered the password obviously.
Sub SplitBook()
Dim xPath As String
Dim FilePath As String
xPath = Application.ThisWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Worksheets
If InStr(xWs.Name, "Store") <> 0 Then
Dim WB As Workbook
Set WB = xWs.Application.Workbooks.Add
ThisWorkbook.Sheets("Compare Depts").Copy Before:=WB.Sheets(1)
Sheets(xWs.Name).Copy Before:=WB.Sheets(2)
FilePath = "\" & Left(xWs.Name, 5) & "_" & Right(xWs.Name, 2)
& "_" & Application.ThisWorkbook.VLookup(Right(xWs.Name, 2),
ThisWorkbook.Sheets("Table").Range(H3, K100), 4)
WB.SaveAs Filename:=xPath & FilePath & ".xls"
WB.Close SaveChanges:=False
Set WB = Nothing
End If
Next xWs
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I found a way to by-pass the password for the old Macro and modified it. This also works, but is much slower than your function #Thomas Inzina
Sub ProcessStoreDistribution()
Application.DisplayAlerts = False
For Each c In ThisWorkbook.Sheets("Table").Range("StoreList")
Process c
Next c
Application.DisplayAlerts = True
MsgBox prompt:="Process Completed"
End Sub
Sub Process(ByVal c As Integer)
Dim wb As Workbook
ThisWorkbook.Activate
StoreNum = WorksheetFunction.VLookup(c, Sheets("Table").Range("StoreTable"), 2)
StoreName = WorksheetFunction.Proper(WorksheetFunction.VLookup(c, Sheets("Table").Range("StoreTable"), 5))
myST = "STORE #" & Right(StoreNum, 2)
mySTN = WorksheetFunction.Substitute(WorksheetFunction.Substitute(ActiveWorkbook.FullName, "PPE", "(PPE"), ".xlsm", ") Store Distribution Files")
Application.DisplayAlerts = False
Sheets(Array("COMPARE DEPTS", myST)).Select
Sheets(Array("COMPARE DEPTS", myST)).Copy
Set wb = ActiveWorkbook
Sheets(Array("COMPARE DEPTS", myST)).Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Sheets("COMPARE DEPTS").Activate
Application.CutCopyMode = False
If Len(Dir(mySTN, vbDirectory)) = 0 Then
MkDir mySTN
End If
mySTN = mySTN & "\STORE_" & StoreNum & "_" & StoreName & ".xls"
wb.SaveAs Filename:=mySTN _
, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
ThisWorkbook.Activate
Application.DisplayAlerts = True
End Sub
Updated
File picker added to get the external workbook.
I had to add a parameter to the VLookup and cast Right(.Name, 2) to an int. Hopefully it's smooth sailing from here.
Option Explicit
Sub ProcessExternalWorkBook()
Dim ExternalFilePath As String, password As String
ExternalFilePath = GetExcelWorkBookPath
If Len(ExternalFilePath) Then
password = Application.InputBox(Prompt:="Enter Password applicable", Type:=2)
SplitBook ExternalFilePath, password
End If
End Sub
Function GetExcelWorkBookPath() As String
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select a Excel WorkBook"
.AllowMultiSelect = False
.InitialFileName = "Path"
.Filters.Clear
.Filters.Add "Excel WorkBooks", "*.xls, *.xlsx, *.xlsm, *.xlsb"
If .Show = -1 Then
GetExcelWorkBookPath = .SelectedItems(1)
End If
End With
End Function
Sub SplitBook(ExternalFilePath As String, Optional sPassword As String)
Dim FilePath As String
Dim wb As Workbook, wbSource As Workbook
Dim xWs As Worksheet
Dim Secured
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set wbSource = Application.Workbooks.Open(Filename:=ExternalFilePath, ReadOnly:=True, password:=sPassword)
For Each xWs In wbSource.Worksheets
If InStr(xWs.Name, "Store") <> 0 Then
Debug.Print xWs.Name & ": was processed"
FilePath = getNewFilePath(xWs)
If Len(FilePath) Then
Sheets(Array("Compare Depts", xWs.Name)).Copy
Set wb = ActiveWorkbook
wb.SaveAs Filename:=FilePath, _
FileFormat:=xlExcel8, password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
wb.Close SaveChanges:=False
Else
MsgBox xWs.Name & " was not found by VLookup", vbInformation
End If
Else
Debug.Print xWs.Name & ": was skipped"
End If
Next xWs
Set wb = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function getNewFilePath(xWs As Worksheet) As String
Dim s As String, sLookup As String
On Error Resume Next
With xWs
sLookup = WorksheetFunction.VLookup(CInt(Right(.Name, 2)), .Parent.Sheets("Table").Range("H3", "K100"), 4, False)
s = ThisWorkbook.Path & "\"
s = s & Left(.Name, 5) & "_" & Right(.Name, 2) & "_" & sLookup
If Err.Number = 0 Then getNewFilePath = s & ".xls"
End With
On Error GoTo 0
End Function
Function getCellValue(cell)
Dim s
s = cell.innerHTML
s = Replace(s, "<br>", "")
s = Replace(s, "<br />", "")
getCellValue = s
End Function