I have used the following code before and worked as expected for a handful times. 4 hours later it did not work. I added the MsgBox "File: " and confirm the filename path is error free.
Option Explicit
Sub ExportAsPDF()
Dim Folder_Path As String
Dim NameOfWorkbook
NameOfWorkbook = Left(ActiveWorkbook.Name, (InStrRev(ActiveWorkbook.Name, ".", -1, vbTextCompare) - 1))
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder path"
If .Show = -1 Then Folder_Path = .SelectedItems(1)
End With
If Folder_Path = "" Then Exit Sub
Dim sh As Worksheet
Dim fn As String
For Each sh In ActiveWorkbook.Worksheets
fn = Folder_Path & Application.PathSeparator & NameOfWorkbook & "_" & sh.Name & ".pdf"
MsgBox "File: " & fn
sh.PageSetup.PaperSize = xlPaperA4
sh.PageSetup.LeftMargin = Application.InchesToPoints(0.5)
sh.PageSetup.RightMargin = Application.InchesToPoints(0.5)
sh.PageSetup.TopMargin = Application.InchesToPoints(0.5)
sh.PageSetup.BottomMargin = Application.InchesToPoints(0.5)
sh.PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
sh.PageSetup.FooterMargin = Application.InchesToPoints(0.5)
sh.PageSetup.Orientation = xlPortrait
sh.PageSetup.CenterHorizontally = True
sh.PageSetup.CenterVertically = False
sh.PageSetup.FitToPagesTall = 1
sh.PageSetup.FitToPagesWide = 1
sh.PageSetup.Zoom = False
sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fn, Quality:=xlQualityStandard, OpenAfterPublish:=True
Next
MsgBox "Done"
End Sub
Is there anything I missed?
Microsoft® Excel® for Microsoft 365 MSO (Version 2211 Build 16.0.15831.20220) 64-bit
If the ActiveWorkbook is new and was never stored, the workbook name is a generic name without any extension, eg Book1. In that case, InStrRev(ActiveWorkbook.Name, ".", -1, vbTextCompare) will return 0. Because you are nesting two commands, this 0 will be passed as parameter to the Left function, and Left(Name, 0) throws that runtime error 5.
Workaround: Write the result of InstrRev into an intermediate variable and check it. My advice is to avoid nested commands because it is much harder to check what exactly fails if there is an error because 0 is an invalid parameter.
Dim p As Long
p = InStrRev(ActiveWorkbook.Name, ".")
If p = 0 Then
NameOfWorkbook = ActiveWorkbook.Name
Else
NameOfWorkbook = Left(ActiveWorkbook.Name, p - 1)
End If
An alternative way to get the filename without extension is to use the FileSystemObject-method GetBaseName (will not work on a Mac)
nameOfWorkbook = CreateObject("Scripting.fileSystemObject").GetBasename(ActiveWorkbook.FullName)
Export Worksheets to Single PDFs
I could produce the error only when a worksheet was not visible (hidden or very hidden). The following deals with that and a few more issues.
Sub ExportAsPDF()
Const PROC_TITLE As String = "Export As PDF"
Const EXPORT_ONLY_VISIBLE_WORKSHEETS As Boolean = False
If ActiveWorkbook Is Nothing Then
MsgBox "No visible workbooks open.", vbExclamation, PROC_TITLE
Exit Sub
End If
Dim swb As Workbook: Set swb = ActiveWorkbook
If Len(swb.Path) = 0 Then
MsgBox "The workbook was not saved yet." & vbLf & vbLf _
& "Save it and try again.", vbExclamation, PROC_TITLE
Exit Sub
End If
Dim dFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Folder path"
If .Show Then dFolderPath = .SelectedItems(1)
End With
If Len(dFolderPath) = 0 Then
MsgBox "No folder selected.", vbExclamation, PROC_TITLE
Exit Sub
End If
Dim swbBaseName As String: swbBaseName = swb.Name
swbBaseName = Left(swbBaseName, InStrRev(swbBaseName, ".") - 1)
Dim dFilePathLeft As String
dFilePathLeft = dFolderPath & Application.PathSeparator & swbBaseName & "_"
Dim sVisibility As XlSheetVisibility: sVisibility = xlSheetVisible
Dim sws As Worksheet
Dim dCount As Long
Dim dFilePath As String
Dim DoExport As Boolean
For Each sws In swb.Worksheets
With sws
If EXPORT_ONLY_VISIBLE_WORKSHEETS Then ' only visible
If .Visible = xlSheetVisible Then DoExport = True
Else ' all
If Not .Visible = xlSheetVisible Then
sVisibility = .Visible ' store
.Visible = xlSheetVisible ' make visible
End If
DoExport = True
End If
If DoExport Then
With .PageSetup
.PaperSize = xlPaperA4
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(0.5)
.BottomMargin = Application.InchesToPoints(0.5)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.Orientation = xlPortrait
.CenterHorizontally = True
.CenterVertically = False
.FitToPagesTall = 1
.FitToPagesWide = 1
.Zoom = False
End With
dFilePath = dFilePathLeft & .Name & ".pdf"
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=dFilePath, _
Quality:=xlQualityStandard, OpenAfterPublish:=True
dCount = dCount + 1
DoExport = False ' reset for the next iteration
End If
If Not EXPORT_ONLY_VISIBLE_WORKSHEETS Then ' all
If Not sVisibility = xlSheetVisible Then
.Visible = sVisibility ' revert
sVisibility = xlSheetVisible ' reset
End If
End If
End With
Next sws
MsgBox dCount & " worksheet" & IIf(dCount = 1, "", "s") & " exported.", _
vbInformation, PROC_TITLE
End Sub
Related
I would like to make exports based on the boxes I checked
therefore with a lot of help I build the following code
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog, xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object, xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String, rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp) 'determine the last cell in A:A
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7)) 'create the range to be exported as pdf
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard, IgnorePrintAreas:=False 'export the range, not the sheet
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If .DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
Private Sub CommandButton2_Click()
Unload basicUserform
End Sub
the problem is when I run the code no attachments show up or can be found in the destination map I choose earlier.
I also put the file here so you can see for yourself.:
https://easyupload.io/ufnmvr
I appreciate your help and time!
Added a check for valid range of 27 or more rows otherwise lastRng.Offset(-26) will fail and because On Error Resume Next was not cancelled with On Error Goto 0 it won't raise an error.
Private Sub CommandButton1_Click()
Dim xSht As Worksheet, xFileDlg As FileDialog
Dim xFolder As String, xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object, xEmailObj As Object
Dim xUsedRng As Range, xArrShetts As Variant
Dim xPDFNameAddress As String, xStr As String
Dim rngExp As Range, lastRng As Range
xArrShetts = sheetsArr(Me) 'do not forget the keep the sheetsArr function...
If UBound(xArrShetts) < 0 Then
MsgBox "No sheets selected", vbExclamation
Exit Sub
End If
' check sheets exist
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & _
xArrShetts(I), vbInformation
Exit Sub
End If
On Error GoTo 0
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & _
"Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if filename already exist
xYesorNo = MsgBox("If same name files exist in the destination folder," & _
"number suffix will be added to the file name automatically " & _
"to distinguish the duplicates " & vbCrLf & vbCrLf & _
"Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
'determine the last cell in A:A
Set lastRng = xSht.Range("A" & xSht.Rows.Count).End(xlUp)
If lastRng.Row < 27 Then
MsgBox "Incorrect Start Row " & lastRng.Row, _
vbCritical, "ERROR on " & xSht.Name
Exit Sub
End If
'create the range to be exported as pdf
Set rngExp = xSht.Range(lastRng.Offset(-26), lastRng.Offset(, 7))
With xSht.PageSetup
.PaperSize = xlPaperA4
.PrintArea = rngExp.Address(0, 0)
.Orientation = xlLandscape
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
'export the range, not the sheet
rngExp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False
xArrShetts(I) = xStr
Else
' no file created
xArrShetts(I) = ""
End If
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.To = ""
.cc = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
If Len(xArrShetts(I)) > 0 Then
.Attachments.Add xArrShetts(I)
End If
Next
.Display ' or ' Send
End With
End Sub
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
I would like to use activeworkbook.changelink like this:
ActiveWorkbook.ChangeLink
Name:= *current workbook*
NewName:= *Open the folder of current workbook from where I can choose the new file*
If I have a link in a cell ("c:\Docs\example.xls") but I want to change it to something (I have more files in c:\Docs, like "example2.xls", "example3.xls",...) the macro should open the folder of c:\Docs\ (Browse dialog) from where I could chose the file I want to use.
Can you suggest me something? Many thanks!
Finally I got time to finish this one. It's working so I share it. Maybe it will be useful for somebody :)
Sub Linkchange()
Const RefText = "#REF"
Dim fd As Office.FileDialog
Dim txtFileName, Msg As String
Dim OldLink_num As Long
Dim ws As Worksheet
Dim FindRef As Range
Dim SheetLoop
Dim FirstAddress
Dim UserOption
alink = ThisWorkbook.LinkSources
If IsEmpty(alink) Then
Msgbox "Nothing is attached."
Else
For Idx = 1 To UBound(alink)
Msg = Msg & (Idx) & ". " & alink(Idx) & vbCrLf & vbNewLine
Next
Msgbox Msg
Linkchange_userform.Show
'Private Sub CommandButton1_Click()
'Dim a As Long
'a = ListBox1.Value
'Msgbox a & ". is chosen"
'Unload Me
'End Sub
'Private Sub ListBox1_Click()
'End Sub
'Private Sub UserForm_Initialize()
'Dim Idx As Long
'alink = ActiveWorkbook.LinkSources
'For Idx = 1 To UBound(alink)
' ListBox1.AddItem Idx
'Next
'ListBox1.ListIndex = 0
'End Sub
OldLink_num = Linkchange_userform.ListBox1.Value
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Pick a file!"
.InitialFileName = Left$(alink(OldLink_num), InStrRev(alink(OldLink_num), "\"))
.Filters.Clear
.Filters.Add "All Files", "*.*"
If .Show = True Then
txtFileName = .SelectedItems(1)
Else
Exit Sub
End If
End With
ActiveWorkbook.ChangeLink Name:=alink(OldLink_num), NewName:=txtFileName, Type:=xlLinkTypeExcelLinks
Msgbox "Ready!"
Application.ScreenUpdating = False
For SheetLoop = 1 To ThisWorkbook.Sheets.Count
Set FindRef = ThisWorkbook.Sheets(SheetLoop).Cells.Find(RefText, lookat:=xlPart, LookIn:=xlValues)
If Not FindRef Is Nothing Then
FirstAddress = FindRef.Address
While Not FindRef Is Nothing
UserOption = Msgbox("Fail at - " & ThisWorkbook.Sheets(SheetLoop).Name & ", cell " & FindRef.Address & vbNewLine & "To continue: OK" & vbNewLine & "To exit: Cancel", vbOKCancel)
If UserOption = vbCancel Then
Exit Sub
End If
Set FindRef = ThisWorkbook.Sheets(SheetLoop).Cells.FindNext(FindRef)
If FindRef.Address = FirstAddress Then
Set FindRef = Nothing
End If
Wend
End If
Next SheetLoop
Application.ScreenUpdating = True
End If
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
I have a macro that imports csv-files into sheets with the same name in a workbook. All the csv files end with ".csv" except for one file which ends with ".CSV". The macro is importing the csv files that end with ".csv" fine. But when it encounters the csv file with ".CSV" it adds a new sheet. I think it's a matter of deactiviting the case sensivity (and I've tried) but I'm not sure. Here's the code:
Private Sub importOrUpdate(opr$)
Dim csvFile, csvArr
Dim wsCSV As Worksheet, wsImport As Worksheet
Dim importFolder$, cnt%, i%
Dim csvName$, idx%, arr, shName$
Dim processed$
U.Start
processed = "|"
csvArr = selectFiles
For i = 0 To UBound(csvArr)
'Workbooks.Open csvArr(i), False, True
Call importToTempSheet(csvArr(i))
Set wsCSV = Tempsheet
idx = InStrRev(csvArr(i), "\") + 1
csvName = Mid(csvArr(i), idx)
csvName = Replace(csvName, ".csv", "")
arr = Split(csvName, "_")
If UBound(arr) = 2 Then
shName = arr(1) & "_" & arr(2)
Else
shName = csvName
End If
On Error Resume Next
Set wsImport = ThisWorkbook.Sheets(shName)
On Error GoTo 0
If wsImport Is Nothing Then
ThisWorkbook.Sheets.Add before:=Sheet14
Set wsImport = ActiveSheet
wsImport.Tab.Color = 5296274
wsImport.Name = shName
Call import(wsCSV, wsImport)
ElseIf opr = "Update" Then
Call update(wsCSV, wsImport)
ElseIf InStr(1, processed, "|" & shName & "|", vbTextCompare) > 0 Then
Call update(wsCSV, wsImport)
Else
Call import(wsCSV, wsImport)
End If
Call updateFormula(wsImport)
processed = processed & shName & "|"
cnt = cnt + 1
'wsCSV.Parent.Close False
Next
Sheet14.Activate
U.Finish
MsgBox cnt & " files imported/updated", vbInformation
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub importToTempSheet(filePath)
Dim lRow&
Tempsheet.Cells.Clear
Dim wsCSV As Worksheet
Workbooks.Open filePath, False, True
Set wsCSV = ActiveWorkbook.Sheets(1)
lRow = wsCSV.Cells(Rows.Count, "A").End(xlUp).Row
wsCSV.Range("A1:A" & lRow).Copy
Tempsheet.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
wsCSV.Parent.Close
Tempsheet.Range("A1:A" & lRow).TextToColumns Tempsheet.Range("A1"), xlDelimited, xlTextQualifierNone, False, False, True, False, False
With Tempsheet
.Range("A:A").NumberFormat = "m/d/yyyy"
convertToDate .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
End With
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function selectFiles()
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select CSV Files"
.ButtonName = "Select"
.AllowMultiSelect = True
.Filters.Clear
.Filters.Add "Excel Files", "*.csv"
.InitialFileName = ThisWorkbook.Path & "\"
.Show
If .SelectedItems.Count = 0 Then
End
Else
Dim csvArr, i%
ReDim csvArr(.SelectedItems.Count - 1)
For i = 1 To .SelectedItems.Count
csvArr(i - 1) = .SelectedItems(i)
Next
selectFiles = csvArr
End If
End With
End Function
The issue is with the replace
try..
csvName = Replace(LCase(csvName), ".csv", "")
or use two replaces...
csvName = Replace(csvName, ".csv", "")
csvName = Replace(csvName, ".CSV", "")