I have a macro that selects worksheets to be printed from worksheets that carry a value in cell A1.
I am trying to adjust the code so that it will print the pdf file with a predetermined name, eg "Output.pdf" and into the folder that the excel file is currently saved
I do not have the VBA skills to do it - I have been trying to find code in various forums, without luck.
My code currently is:
Sub Print_All_Worksheets_With_Value_In_A1()
Dim Sh As Worksheet
Dim Arr() As String
Dim N As Integer
N = 0
Application.ActivePrinter = "Adobe PDF on Ne07:"
For Each Sh In ActiveWorkbook.Worksheets
If Sh.Visible = xlSheetVisible And Sh.Range("A1").Value <> "" Then
N = N + 1
ReDim Preserve Arr(1 To N)
Arr(N) = Sh.Name
End If
Next
With ActiveWorkbook
.Worksheets(Arr).PrintOut
End With
End Sub
Any help with refining this area i n particular will be greatly appreciated
With ActiveWorkbook
.Worksheets(Arr).PrintOut
I have a slightly different idea for how to do this.
You have created an array of worksheets with Arr variable. I think instead of this:
With ActiveWorkbook
.Worksheets(Arr).PrintOut ...
End With
Do this:
Dim path as String
'Capture the path of the current workbook
path = ActiveWorkbook.Path & "\"
'The copy method will create a NEW workbook with these sheets
ActiveWorkbook.Worksheets(arr).Copy
'The NEW workbook is now "Active", so use ActiveWorkbook and exportAsFixedFormat
ActiveWorkbook.ExportAsFixedFormat xlTypePDF, path & "output.pdf"
'Closes the temporary workbook without warning
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
Related
I have a directory with 6 sub-folders and ~300 excel workbooks(Growing every day).
Each workbook has multiple formulas (~1200 per workbook) that reference a CSV data dump stored on a server path.
My issue is that excel treats the CSV data dump as "dirty data" and prompts warnings every time a workbook is opened claiming it can't update the links(But when the links are checked, excel then says there's no issue).
In all my research I've found there doesn't seem to be a way to fix this other than replace the datasource with a .xsl file which excel doesn't have any issues referencing.
What I need to do, is perform a find and replace on ~300 workbooks, find the CSV server path inside the formulas and replace it with the new server path for the .xls file.
I've tried "Sobolsoft's Excel Find and Replace" software, but that doesn't seem to want to look inside formulas to replace. I've used "Easy-XL" and "Kutools" both of which only work on open workbooks (Which I could live with, if I had to open 20-50 workbooks at a time, run the find and replace, then open the next batch) but neither of them wanted to work either.
I've used the following macro to unprotect/protect each workbook in the directory which works perfectly
Const cStartFolder = "M:\Transfer\DrillHole_Interaction\4.For_Survey" 'no slash at end
Const cFileFilter = "*.xlsm"
Const cPassword = "" 'use empty quotes if blank
Sub UnprotectAllWorksheets()
Dim i As Long, j As Long, arr() As String, wkb As Workbook, wks As Worksheet
ExtractFolder cStartFolder, arr()
On Error Resume Next
j = -1: j = UBound(arr)
On Error GoTo 0
For i = 0 To j
Set wkb = Workbooks.Open(arr(i), False)
For Each wks In wkb.Worksheets
wks.Protect cPassword, True, True
Next
wkb.Save
wkb.Close
Next
End Sub
Sub ExtractFolder(Folder As String, arr() As String)
Dim i As Long, objFS As Object, objFolder As Object, obj As Object
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(Folder)
For Each obj In objFolder.SubFolders
ExtractFolder obj.Path, arr()
Next
For Each obj In objFolder.Files
If obj.Name Like cFileFilter Then
On Error Resume Next
i = 0: i = UBound(arr) + 1
On Error GoTo 0
ReDim Preserve arr(i)
arr(i) = objFolder.Path & Application.PathSeparator & obj.Name
End If
Next
End Sub
If it would help, I'm also open to copying from a 'Master' workbook and copying the specific range into each other workbook (Copy range to range for each book) but I'm at my wits end and do not know how to proceed.
Any help would be appreciated.
No need to find and replace the csv fullname (path & filename) within all formulas, just change the links source at once within each workbook.
Try this within a loop through all workbooks that need to be changed.
Dim Wbk As Workbook
Application.DisplayAlerts = False
Set Wbk = Workbooks.Open(Filename:="WbkTarget.Fullname", UpdateLinks:=3)
With Wbk
.ChangeLink _
Name:="CsvFile.Fullname", _
NewName:="XlsFile.Fullname", _
Type:=xlExcelLinks
.Save
.Close
End With
Application.DisplayAlerts = True
where:
WbkTarget.Fullname: Path and name of the workbook with the link to be replaced
CsvFile.Fullname: Path and name of the csv file to be replaced
XlsFile.Fullname: Path and name of the xls that replaces the csv file
I have the below code.
Very simply it asks the user to select multiple excel workbooks and then will copy and paste data from those workbooks to the current work book.
1.
I would like to add the functionality, whereby instead of the user selecting the excel workbooks. The excel workbooks will be selected in that their names are listed on the current excel sheet.
For example - Select excel workbooks in specified folder whose names are listed in A1:A5.
I would like to perform automatic processing on the data before it is copied into the current work book.
For example if workbook name = 100.xlsx then multiply selection by 15.
See my current code
Sub SUM_BalanceSheet()
Application.ScreenUpdating = False
'FileNames is array of file names, file is for loop, wb is for the open file within loop
'PasteSheet is the sheet where we'll paste all this information
'lastCol will find the last column of PasteSheet, where we want to paste our values
Dim FileNames
Dim file
Dim wb As Workbook
Dim PasteSheet As Worksheet
Dim lastCol As Long
Set PasteSheet = ActiveSheet
lastCol = PasteSheet.Cells(1, Columns.Count).End(xlToLeft).Column
'Build the array of FileNames to pull data from
FileNames = Application.GetOpenFilename(filefilter:="Excel Files (*.xlsx), *.xlsx", MultiSelect:=True)
'If user clicks cancel, exit sub rather than throw an error
If Not IsArray(FileNames) Then Exit Sub
'Loop through selected files, put file name in row 1, paste P18:P22 as values
'below each file's filename. Paste in successive columns
For Each file In FileNames
Set wb = Workbooks.Open(file, UpdateLinks:=0)
PasteSheet.Cells(1, lastCol + 1) = wb.Name
wb.Sheets("Page 1").Range("L14:L98").Copy
PasteSheet.Cells(2, lastCol + 1).PasteSpecial Paste:=xlPasteValues
wb.Close SaveChanges:=False
lastCol = lastCol + 1
Next
'If it was a blank sheet then data will start pasting in column B, and we don't
'want a blank column A, so delete it if it's blank
If Cells(1, 1) = "" Then Cells(1, 1).EntireColumn.Delete shift:=xlLeft
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
This is a frame that needs fine-tuning, but you can get the idea:
Dim i&, wbName$
Dim rng As Excel.Range
Dim wb, wb1 As Excel.Workbook
Set wb = Application.ThisWorkbook
Set rng = wb.Sheets("Sheet1").Range("A1")
For i = 0 To 14
wbName = CStr(rng.Offset(i, 0).Value)
On Error Resume Next 'Disable error handling. We will check whether wb is nothing later
wb1 = Application.Workbooks.Open(wbName, False)
On Error GoTo ErrorHandler
If Not IsNothing(wb1) Then
'Copy-paste here
If wb1.Name = "100" Then 'any condition(s)
'Multiply, divide, or whatever
End If
End If
Next
ErrorHandler:
MsgBox "Error " & Err.Description
'Add additional error handling
Try not to use ActiveSheet and ActiveWorkbook without absolute need. Use ThisWorkbook, dedicated Workbook object, and named sheet Workbook.Sheets("Name") or Workbook.Sheets(index) instead.
Alternatively instead of disabling error checking you can do it and fail if a file is missing.
I have a problem. I'm guessing its easier to first write the code, and then explain it so here goes:
Sub Test()
Dim myHeadings() As String
Dim i As Long
Dim path As String
Dim pathtwo As String
Dim currentWb As Workbook
Dim openWb As Workbook
Dim openWs As Worksheet
Set currentWb = ActiveWorkbook
path = "C:\pathto\"
pfile = Split("File1,File2,File3", ",")
myHeadings = Split("Januari,Februari,Mars,April,Maj,Juni,Juli,Augusti,September,Oktober,November,December", ",")
For j = 0 To UBound(pfile)
pathtwo = path & pfile(j) & ".xlsx"
i = 0
If IsFile(pathtwo) = True Then
For i = 0 To UBound(myHeadings)
Set openWb = Workbooks.Open(pathtwo)
Set openWs = openWb.Sheets(myHeadings(i))
If openWs.Range("C34") = 0 Then
currentWb.Sheets("Indata").Cells(70, i + 27 + 12*j.Value = ""
Else
currentWb.Sheets("Indata").Cells(70, i + 27 + 12*j).Value = openWs.Range("C34")
End If
Next i
End if
Workbooks(openWb.Name).Close
Next j
End sub
What I want to pick a file from the pfile list, iterate through all its sheets defined in myHeadings and deduct the value at C34 (in reality there are plenty more values deducted, but to keep it short). After this I want to Close the file, go to the next file and do the same thing until all the Three files (again, in reality there are more, which some of them does not exist yet).
The function "IsFile" is
Function IsFile(fName As String) As Boolean
'Returns TRUE if the provided name points to an existing file.
'Returns FALSE if not existing, or if it's a folder
On Error Resume Next
IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory)
End Function
written by iDevlop at stackoverflow, in this thread: VBA check if file exists
The reason why I have
currentWb.Sheets("Indata").Cells(70, i + 27 + 12*j).Value = openWs.Range("C34")
is because I want to start to write my data into currentWb at AA70 (Row 70, column 27). j*12 is because it is "periodic" depending on which file it is (the file file1 corresponds to 2015, file2 to 2016 etc), and hence in my summary I have it month and yearwise.
The problem arises though when I run this macro, at the first file at the sheet Mars I get out of range, but Before I added the iteration of files, there was not any subscript out of range at the first file. Is there anyone who can see how this can be?
Please note that indentation and so on may be somewhat off as I copied this from a much larger file with many rows in between with irrelevant code.
This isnt the right answer for your specific question but this is how I have done something similar and might help you to see how i did it. Basically what this is doing is opening up a CSV and copying the entire sheet and pasting it into a workbook. I was consolidating like 20 CSV dumps into 1 workbook to make it easier to dig through the stuff.
Regarding Dir()
You can invoke Dir with 2 arguments or with no arguments. You initialize it with 2 arguments the pathway and the attributes (which is optional). The 2nd time I am calling Dir in this sub it is without any arguments. What this does is fetch the subsequent files.
Sub Add_Sheets()
Dim ws As Worksheet
Dim PasteSheet As Worksheet
Dim wb As Workbook
Set wb = Application.Workbooks.Open("C:\Users\Desktop\CSV\All.xlsx") 'Location of where you want the workbook to be
StrFile = Dir("c:\Users\Desktop\CSV\*.csv") 'Dir of where all the CSVs were.
Do While Len(StrFile) > 0
Debug.Print StrFile
Application.Workbooks.Open ("c:\Users\Desktop\CSV\" & StrFile)
Set ws = ActiveSheet
ws.Range("A1:C" & rows.Count).Select 'Selecting Specific content on the worksheet
Selection.Copy
wb.Activate
wb.Worksheets.add(After:=Worksheets(Worksheets.Count)).name = StrFile 'Setting the sheet name to the name of the CSV file
Range("A1").PasteSpecial Paste:=xlPasteValues
StrFile = Dir
Loop
End Sub
I am working on writing a VBA code to export some of the sheets in excel to same PDF. I have several chart sheets in my excel file each of which name ends with "(name)_Chart".
I want to export all sheets with names ending wioth chart to one PDF file.
Here is the code I am trying to write.
Sub FindWS()
'look if it at least contains part of the name
Dim s As Worksheet
Dim strPath As String
strPath = ActiveWorkbook.Path & "\"
For Each s In ThisWorkbook.Sheets
If InStr(1, s.Name, Chart) Then
s.Activate
ActiveSheet.ExportAsFixedFormat xlTypePDF, strPath & s.Name & ".pdf"
Exit Sub
End If
Next s
End Sub
This code is not limting export to only the chart sheets but exporting thy whole workbook. Can anyone help me with figurint out whats is missing in my code.
Thanks!
MODIFIED CODE:
Sub FindWS()
'look if it at least contains part of the name
Dim s As Worksheet
Dim strPath As String
strPath = ActiveWorkbook.Path & "\"
For Each s In ThisWorkbook.Worksheets
If InStr(1, s.Name, "Chart") = 0 Then
' Hide the sheet so it is not exported as PDF
s.Visible = False
End If
Next s
With ActiveWorkbook
.ExportAsFixedFormat xlTypePDF, strPath & "TEST.pdf"
End With
End Sub
I am surprised that your code is running in the first place :) You should have actually got an error run time error '13', type mismatch
Sheets and Worksheets are two different things in Excel
The Worksheets collection is a collection of all the Worksheet objects in the specified or active workbook. Each Worksheet object represents a worksheet. Whereas the Sheets collection, on the other hand, consist of not only a collection of worksheets but also other types of sheets to include Chart sheets, Excel 4.0 macro sheets and Excel 5.0 dialog sheets.
So if you declare your object as Worksheet
Dim s As Worksheet
Then ensure that while looping you loop through the correct collection
For Each s In ThisWorkbook.Worksheets
and not
For Each s In ThisWorkbook.Sheets
else you will get a run time error '13', type mismatch
FOLLOWUP (Based on Comments)
# Siddharth: 1. Yes, I want to export Chart sheets that ends with name "Chart". 2. I want all those charts in one PDF and the name of the PDF should be the "original" file name. (I will have to save the final PDF files in different location so there will be no overlapping of files.) – datacentric
Option Explicit
Sub Sample()
Dim ws As Object
Dim strPath As String, OriginalName As String, Filename As String
On Error GoTo Whoa
'~~> Get activeworkbook path
strPath = ActiveWorkbook.Path & "\"
'~~> Get just the name without extension and path
OriginalName = Left(ActiveWorkbook.Name, (InStrRev(ActiveWorkbook.Name, ".", -1, vbTextCompare) - 1))
'~~> PDF File name
Filename = strPath & OriginalName & ".pdf"
'~~> Loop through Sheets Collesction
For Each ws In ActiveWorkbook.Sheets
'~~> Check if it is a Chart Sheet and also it ends in "Chart"
If ws.Type = 3 And UCase(Right(Trim(ws.Name), 5)) = "CHART" Then
ws.Visible = True
Else
ws.Visible = False
End If
Next ws
'~~> Export to pdf
ActiveWorkbook.ExportAsFixedFormat xlTypePDF, Filename
LetsContinue:
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
This code will look through all the sheets. If the sheet name doesn't match it will hide it. When it's finished that it exports all visible sheets into one PDF. Make sure yuo don't save the Excel file afterwards or the sheets will remain hidden.
Of course this code is not tested so if you have issues ask back (or try and resolve themself as you may learn something)
Sub FindWS()
'look if it at least contains part of the name
Dim s As Worksheet
Dim strPath As String
strPath = ActiveWorkbook.Path & "\"
For Each s In ThisWorkbook.Sheets
If InStr(1, s.Name, "Chart") = 0 Then
' Hide the sheet so it is not exported as PDF
s.Visible = False
End If
Next s
' Export all sheets as PDF
ActiveSheet.ExportAsFixedFormat xlTypePDF, strPath & "TEST.pdf"
End Sub
My work is regarding formating 100 of files everyday. though i have a macro desined for the purpose but i have to run the macro on each and every file one after saving previous.
my question is how can i be able to run my macro on these opened workbooks in one step. As i save one it would run on other one in the queue.
Put the following macro in a "BASE" workbook as Passerby mentioned
Sub SO()
Dim macroList As Object
Dim workbookName As String
Dim wbFullPath
Dim macroName As String
Dim currentWb As Workbook
Dim masterWb As Workbook ' the Excel file you are calling this procedure from
Dim useWbList As Boolean
Dim height As Long, i As Long
Dim dataArray As Variant
useWbList = False ' DEFINE which input method
Set macroList = CreateObject("Scripting.Dictionary")
If useWbList Then
' you can also from the dictionary from 2 columns of an excel file , probably better for management
With masterWb.Worksheets("Sheet1") '<~~ change Sheet1 to the sheet name storing the data
height = .Cells(.Rows.Count, 1).End(xlUp).Row ' Assume data in column A,B, starting from row 1
If height > 1 Then
ReDim dataArray(1 To height, 1 To 2)
dataArray = .Range(.Cells(1, 1), .Cells(height, 2)).Value
For i = 1 To height
macroList.Add dataArray(i, 1), dataArray(i, 2)
Next i
Else
'height = 1 case
macroList.Add .Cells(1, 1).Value, .Cells(1, 2).Value
End If
End With
Else
' ENTER THE FULl PATH in 1st agrument below, Macro Name in 2nd argument
' Remember to make sure the macro is PUBLIC, try to put them in Module inside of Sheets'
macroList.Add "C:\Users\wangCL\Desktop\Book1.xlsm", "ThisWorkbook.testing"
'macroList.Add "FULL PATH", "MACRO NAME"
'macroList.Add "FULL PATH", "MACRO NAME"
'macroList.Add "FULL PATH", "MACRO NAME"
End If
Application.DisplayAlerts = False
For Each wbFullPath In macroList.keys
On Error GoTo 0
macroName = macroList.Item(workbookName)
workbookName = Mid(wbFullPath, InStrRev(wbFullPath, "\") + 1)
Err.Clear
On Error Resume Next
Set currentWb = Nothing
Set currentWb = Workbooks(workbookName) ' see if the workbook is already open
If Err.Number <> 0 Then
' open the workbook if workbook NOT opened
Set currentWb = Workbooks.Open(workbookName, ReadOnly:=True)
End If
On Error GoTo 0
' run the macro
Application.Run workbookName & "!" & macroList.Item(wbFullPath)
'close the workbook after running the macro
currentWb.Close saveChanges:=False
Set currentWb = Nothing
Next wbFullPath
End Sub
Hope it helps and please let me know if there's anything unclear
I have got my solve using below code.
Sub OpenAllWorkbooksnew()
Set destWB = ActiveWorkbook
Dim DestCell As Range
Dim cwb As Workbook
For Each cwb In Workbooks
**Call donemovementReport**
ActiveWorkbook.Close True
ActiveWorkbook.Close False
Next cwb
End Sub