I need to create a new Excel file with data from a main (with VBA) Excel file.
I can only Save as and it is saving my main Excel file.
I need a copy of this file with certain cells and columns.
How the copy of the Excel file should look
I have this.
Private Sub CommandButton2_Click()
Dim newExcel As Excel.Application
Dim newWorkbook As Excel.Workbook
Dim newWorkSheet As Excel.Worksheet
Set newExcel = CreateObject("Excel.Application")
Set newWorkbook = newExcel.Workbooks.Add
Set newWorkSheet = newWorkbook.Worksheets(1)
newWorkSheet.Range("A1") = "Klients"
newWorkSheet.Range("B1") = "Bilance 06.17"
newWorkSheet.Range("C1") = "Bilance 07.17"
newWorkSheet.Range("D1") = "Bilance 08.17"
newWorkSheet.Range("E1") = "Bilance 09.17"
newWorkSheet.Range("F1") = "Bilance 10.17"
newWorkSheet.Range("G1") = "Kopa"
newWorkSheet.Range("A2") = TextBox1.Text
newWorkSheet.Range("B2") = TextBox2.Text
newWorkSheet.Range("C2") = TextBox3.Text
newWorkSheet.Range("D2") = TextBox4.Text
newWorkSheet.Range("E2") = TextBox5.Text
newWorkSheet.Range("F2") = TextBox6.Text
newWorkSheet.Range("G2") = TextBox7.Text
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & newExcel
.Execute
End Sub
Try maybe this:
With newExcel
.Visible = True
With .FileDialog(msoFileDialogSaveAs)
.InitialFileName = "C:\Users\" & Environ("UserName") & "\Desktop\" & newExcel.Workbooks(1).name
.Show
'.Execute
End With
' If you nedd to close
.Quit
Thisworkbook.Activate
End With
Create a new instance, copy the values to it and then save that instance(new). You haven't shown the code where you tried to save it. newWorkbook.saveas where you put the filename parameter from filedialogbox should work.
Or just do NewWorkbook.Save since it is a new workbook, the filename picker may apper by default.
Related
I'm trying figure out how to modify the code I came across (can be found below). So instead of it making the worksheets as pages to pdf, I would want it to make them as individual pdf files. It should ass well avoid certain list of names for example:
"pricing",
"cover" and
"important",
and it should take the name from the sheet it's making the pdf from. I'm at a dead end right now, so might as well ask.
Here's to code (This code selects the file the Excels are in, makes you choose where the pdf files go to and loops trough every worksheet in the folder (For instance i got 50 files with 3 sheets each and I need each sheet as their own pdf:s to be an attachment for an invoice)):
Sub ExcelSaveAsPDF()
Dim strPath As String
Dim xStrFile1, xStrFile2 As String
Dim xWbk As Workbook
Dim xSFD, xRFD As FileDialog
Dim xSPath As String
Dim xRPath, xWBName As String
Dim xBol As Boolean
Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
With xSFD
.Title = "Please select the folder contains the Excel files you want to "
convert:"
.InitialFileName = "C:\"
End With
If xSFD.Show <> -1 Then Exit Sub
xSPath = xSFD.SelectedItems.Item(1)
Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
With xRFD
.Title = "Please select a destination folder to save the converted files:"
.InitialFileName = "C:\"
End With
If xRFD.Show <> -1 Then Exit Sub
xRPath = xRFD.SelectedItems.Item(1) & "\"
strPath = xSPath & "\"
xStrFile1 = Dir(strPath & "*.*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While xStrFile1 <> ""
xBol = False
If Right(xStrFile1, 3) = "xls" Then
Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
xbwname = Replace(xStrFile1, ".xls", "_pdf")
xBol = True
ElseIf Right(xStrFile1, 4) = "xlsx" Then
Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
xbwname = Replace(xStrFile1, ".xlsx", "_pdf")
xBol = True
ElseIf Right(xStrFile1, 4) = "xlsm" Then
Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
xbwname = Replace(xStrFile1, ".xlsm", "_pdf")
xBol = True
End If
If xBol Then
xWbk.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xRPath & xbwname & ".pdf"
xWbk.Close SaveChanges:=False
End If
xStrFile1 = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Credits to U/Jimm_kirkk for helping with this project.
My original reddit Post: [Here][1]!
Code explanation:
Makes you select the folder that contains the Excel files and where the pdf files go to.
After that it makes every sheet ad individual pdf.
In the code is a place you can set a list of names to avoid printing as pdf.
Takes around a minute per 10 excel files.
The code:
Sub ExcelSaveAsPDF()
Dim strPath As String
Dim xStrFile1, xStrFile2 As String
Dim xWbk As Workbook
Dim xSFD, xRFD As FileDialog
Dim xSPath As String
Dim xRPath, xWBName As String
Dim xBol As Boolean
Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
With xSFD
.Title = "Please select the folder contains the Excel files you want to convert:"
.InitialFileName = "C:\"
End With
If xSFD.Show <> -1 Then Exit Sub
xSPath = xSFD.SelectedItems.Item(1)
Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
With xRFD
.Title = "Please select a destination folder to save the converted files:"
.InitialFileName = "C:\"
End With
If xRFD.Show <> -1 Then Exit Sub
xRPath = xRFD.SelectedItems.Item(1) & "\"
strPath = xSPath & "\"
xStrFile1 = Dir(strPath & "*.*")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While xStrFile1 <> ""
xBol = False
If Right(xStrFile1, 3) = "xls" Then
Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
'modified xbwname to be simplified name
xbwname = Replace(xStrFile1, ".xls", "")
xBol = True
ElseIf Right(xStrFile1, 4) = "xlsx" Then
Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
'modified xbwname to be simplified name
xbwname = Replace(xStrFile1, ".xlsx", "")
xBol = True
ElseIf Right(xStrFile1, 4) = "xlsm" Then
Set xWbk = Workbooks.Open(Filename:=strPath & xStrFile1)
'modified xbwname to be simplified name
xbwname = Replace(xStrFile1, ".xlsm", "")
xBol = True
End If
If xBol Then
'modified here to install sub main_ExportPDF()
Sheet_ExportPDF xWbk, xRPath & xbwname
''''''''''''''''''''''''''''''''''''''''''''''
xWbk.Close SaveChanges:=False
End If
xStrFile1 = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Sheet_ExportPDF(wb As Workbook, fname As String)
'Purpose: determine sheets to be exported to pdf
'store base workbook name
Dim baseWB As String
baseWB = fname
'user to define what names to avoid by adding to string
Const NTA As String = "pricing,cover,important"
'build array of names to avoid
Dim NamesToAvoid As Variant
NamesToAvoid = Split(NTA, ",")
'process visible worksheets and compare to NamesToAvoid, export the
'sheets that are not in conflict with user's list to avoid
Dim ws As Worksheet, blnConflict As Boolean, i As Long
For Each ws In wb.Worksheets
'determine if sheet is visible
If ws.Visible = xlSheetVisible Then
'loop through user's list to avoid
For i = LBound(NamesToAvoid) To UBound(NamesToAvoid)
'if on the avoidance list, set bln and exit loop
If UCase(ws.Name) = Trim(UCase(NamesToAvoid(i))) Then
blnConflict = True
Exit For
End If
Next i
'process appropriate safe sheets
fname = baseWB & "_" & ws.Name & ".pdf"
If Not blnConflict Then ExportPDF ws, fname Else blnConflict = False
End If
Next ws
End Sub
Function ExportPDF(sht As Worksheet, fname As String)
'Purpose: facilitate exporting to pdf
'execute the exporting with some basic parameters set to user's needs
sht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=fname, quality:=xlQualityStandard, _
includedocproperties:=True, ignoreprintareas:=True, openafterpublish:=False
End Function
good luck!
VBA code not looping through the folder of .csv's
The code below is doing the function I need but is not looping and it would be good to add a line to delete the .csv's once copied
Option Explicit
Private Sub SaveAs_Files_in_Folder()
Dim CSVfolder As String, XLSfolder As String
Dim CSVfilename As String, XLSfilename As String
Dim template As String
Dim wb As Workbook
Dim wbm As Workbook 'The template I want the data pasted into
Dim n As Long
CSVfolder = "H:\Case Extracts\input" 'Folder I have the csv's go
XLSfolder = "H:\Case Extracts\output" 'Folder for the xlsx output
If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"
n = 0
CSVfilename = Dir(CSVfolder & "*.csv", vbNormal)
template = Dir("H:\Case Extracts\template.xlsx", vbNormal)
While Len(CSVfilename) <> 0
n = n + 1
Set wb = Workbooks.Open(CSVfolder & CSVfilename)
Range("A1:M400").Select
Selection.Copy
Set wbm = Workbooks.Open(template, , , , "Password") 'The template has a password
With wbm
Worksheets("Sheet2").Activate
Sheets("Sheet2").Cells.Select
Range("A1:M400").PasteSpecial
Worksheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
wbm.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
wbm.Close
End With
With wb
.Close False
End With
CSVfilename = Dir()
Wend
End Sub
The code works for the first .csv file I just can't get the loop to keep going through the files. It would also be good to add a line to delete the .csv's once they have been copied
Work with objects. You may want to see How to avoid using Select in Excel VBA. Declare objects for both the csv and template and work with them.
Your DIR is not working because of template = Dir("H:\Case Extracts\template.xlsx", vbNormal) which is right after CSVfilename = Dir(CSVfolder & "*.csv", vbNormal). It is getting reset. Reverse the position as shown below. Move it before the loop as #AhmedAU mentioned.
Copy the range only when you are ready to paste. Excel has an uncanny habit of clearing the clipboard. For example, I am pasting right after I cam copying the range.
Is this what you are trying? (Untested)
Option Explicit
Private Sub SaveAs_Files_in_Folder()
Dim CSVfolder As String, XLSfolder As String
Dim CSVfilename As String, XLSfilename As String
Dim wbTemplate As Workbook, wbCsv As Workbook
Dim wsTemplate As Worksheet, wsCsv As Worksheet
CSVfolder = "H:\Case Extracts\input" '<~~ Csv Folder
XLSfolder = "H:\Case Extracts\output" '<~~ For xlsx output
If Right(CSVfolder, 1) <> "\" Then CSVfolder = CSVfolder & "\"
If Right(XLSfolder, 1) <> "\" Then XLSfolder = XLSfolder & "\"
XLSfilename = Dir("H:\Case Extracts\template.xlsx", vbNormal)
CSVfilename = Dir(CSVfolder & "*.csv")
Do While Len(CSVfilename) > 0
'~~> Open Csv File
Set wbCsv = Workbooks.Open(CSVfolder & CSVfilename)
Set wsCsv = wbCsv.Sheets(1)
'~~> Open Template file
Set wbTemplate = Workbooks.Open(XLSfolder & XLSfilename, , , , "Password")
'~~> Change this to relevant sheet
Set wsTemplate = wbTemplate.Sheets("Sheet1")
'~~> Copy and paste
wsCsv.Range("A1:M400").Copy
wsTemplate.Range("A1").PasteSpecial xlPasteValues
'~~> Save file
wbTemplate.SaveAs Filename:=XLSfolder & CSVfilename & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook
'~~> Close files
wbTemplate.Close (False)
wbCsv.Close (False)
'~~> Get next file
CSVfilename = Dir
Loop
'~~> Clear clipboard
Application.CutCopyMode = False
End Sub
I think must be something like this, adapted to very fast looping through huge of csvs files
reference “Microsoft Scripting Runtime” (Add using
Tools->References from the VB menu)
Sub SaveAs_Files_in_Folder()
Dim myDict As Dictionary, wb As Workbook, eachLineArr As Variant
Set myDict = CreateObject("Scripting.Dictionary")
CSVfolder = "H:\Case Extracts\input\"
XLSfolder = "H:\Case Extracts\output\"
Template = ThisWorkbook.path & "\template.xlsx"
fileMask = "*.csv"
csvSeparator = ";"
csvLineBreaks = vbLf ' or vbCrLf
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
.Calculation = xlManual
'.Visible = False ' uncomment to hide templates flashing
End With
LookupName = CSVfolder & fileMask
Results = CreateObject("WScript.Shell").Exec("CMD /C DIR """ & LookupName & Chr(34) & " /S /B /A:-D").StdOut.ReadAll
filesList = Split(Results, vbCrLf)
For fileNr = LBound(filesList) To UBound(filesList) - 1
csvLinesArr = Split(GetCsvFData(filesList(fileNr)), csvLineBreaks) ' read each csv to array
ArrSize = UBound(Split(csvLinesArr(lineNr), csvSeparator))
For lineNr = LBound(csvLinesArr) To UBound(csvLinesArr)
If csvLinesArr(lineNr) <> "" Then
eachLineArr = Split(csvLinesArr(lineNr), csvSeparator) ' read each line to array
ReDim Preserve eachLineArr(ArrSize) ' to set first line columns count to whoole array size
myDict.Add Dir(filesList(fileNr)) & lineNr, eachLineArr ' put all lines into dictionary object
End If
Next lineNr
Set wb = Workbooks.Open(Template, , , , "Password")
wb.Worksheets("Sheet1").[a1].Resize(myDict.Count, ArrSize) = TransposeArrays1D(myDict.Items)
Set fso = CreateObject("Scripting.FileSystemObject")
csvName = fso.GetBaseName(filesList(fileNr))
Set fso = nothing
wb.SaveAs FileName:=XLSfolder & csvName & ".xlsx"
wb.Close
Set wb = Nothing
Next fileNr
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.EnableEvents = True
.Calculation = xlManual
.Visible = True
End With
End Sub
Function GetCsvFData(ByVal filePath As String) As Variant
Dim MyData As String, strData() As String
Open filePath For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
GetCsvFData = MyData
End Function
Function TransposeArrays1D(ByVal arr As Variant) As Variant
Dim tempArray As Variant
ReDim tempArray(LBound(arr, 1) To UBound(arr, 1), LBound(arr(0)) To UBound(arr(0)))
For y = LBound(arr, 1) To UBound(arr, 1)
For x = LBound(arr(0)) To UBound(arr(0))
tempArray(y, x) = arr(y)(x)
Next x
Next y
TransposeArrays1D = tempArray
End Function
I have a macro that get data from a word file and writes it into an excel file and saves it to a specific location.
I want the user to be able to choose where to save the file.
This is my current code:
Sub createExcelFile()
Dim mPathSave As String
Dim xlsApp As Excel.Application
Dim xlsWB As Workbook
Set xlsApp = CreateObject("Excel.Application")
Set xlsWB = xlsApp.Workbooks.Add
'Want to make it dynamic'
mPathSave = "C:\temp"
callFunc = createExcel.createExcel(xlsApp, xlsWB)
'Save the excel file
xlsWB.SaveAs mPathSave & "\" & "teste" & ".xls", FileFormat:=56
xlsWB.Close
xlsApp.Quit
MsgBox "Novo arquivo salvo em: " & mPathSave & "\" & "teste" & ".xls", vbInformation
End Sub
I tried to use Application.FileDialog to open the dialog to choose the place, but I can't make it save a excel, it opens to save a word file.
Here is a simple example
Sub createExcelFile()
Dim mPathSave As String
Dim xlsApp As Excel.Application
Dim xlsWB As Workbook
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = True
Set xlsWB = xlsApp.Workbooks.Add
'Want to make it dynamic'
Application.FileDialog(msoFileDialogFolderPicker).Show
mPathSave = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
'Save the excel file
xlsWB.SaveAs mPathSave & "\" & "teste" & ".xls", FileFormat:=56
xlsWB.Close
xlsApp.Quit
End Sub
I have a worksheet (QT) that gets filled in by the user and when the user closes the workbook a UserForm appears before closing. The user then selects a few things and the code runs. The code inserts data into another workbook (Log). My problem is the other workbook (Log) asks the user if they would like to save. I need for this step to be skipped. I have tried Application.DisplayAlerts = False but it does not prevent it from popping up.
Private Sub OKBTN_Click()
Dim TOTALFOB As String
Dim TOTALWC As String
Dim MFG As String
Dim JOB As String
Dim XL As Excel.Application
Dim wbk As Excel.Workbook
Dim INWBK As Excel.Workbook
Dim TOTMFG As Variant
Dim TOTWC As Variant
Dim visitdate As Date
Dim visitdate_text As String
TOTALFOB = RefEdit1
TOTALWC = RefEdit2
Set XL = CreateObject("Excel.Application")
Set INWBK = ActiveWorkbook
Set wbk = XL.Workbooks.Open("C:\QUOTE REQUEST LOG 2015.xlsm")
If YESBTN.Value = True Then TOTMFG = INWBK.Sheets("QTR").Range(TOTALFOB).Value
If YESBTN.Value = True Then TOTWC = INWBK.Sheets("QTR").Range(TOTALWC).Value
If NOBTN.Value = True Then TOTMFG = "N/A"
If NOBTN.Value = True Then TOTWC = "N/A"
MFG = INWBK.Sheets("QTR").Range("B7").Value
JOB = INWBK.Sheets("QTR").Range("H13").Value
visitdate = INWBK.Sheets("QTR").Range("H9").Value
visitdate_text = Format$(visitdate, "mm\-dd\-yyyy")
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(1, 0) = INWBK.Sheets("QTR").Range("B7").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 1) = INWBK.Sheets("QTR").Range("H11").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 3) = INWBK.Sheets("QTR").Range("H13").Value
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 4) = TOTMFG
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 5) = TOTWC
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 6) = "OPEN"
wbk.Sheets("QTR_LOG").Range("B" & Rows.Count).End(xlUp).Offset(0, 7) = INWBK.Sheets("QTR").Range("H9").Value
Application.DisplayAlerts = False
INWBK.SaveAs Filename:="C:\. QUOTE REQUESTS" & _
"\DCS QTR " & MFG & " " & " " & JOB & " " & visitdate_text & ".xlsx", _
FileFormat:=51, CreateBackup:=False, local:=True
Set XL = Nothing
Unload Me
wbk.Close
End Sub
Code from output file (Workbook Log):
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ThisWorkbook.Save
End Sub
try ThisWorkbook.Saved = True
Even if the workbook is not saved, excel will act as if it was saved
I've looked on many sites, including all the questions that came up when I entered my title, and I can't seem to get my program to work. It activates the spreadsheet, but no data prints.
Option Explicit
Dim objExcel, objWorkbook
Dim strTIN, strName, strFName, strLName, strState, strEmpID, strRecDate, strComment
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("C:\Users\lpeder6\Desktop\Important Info\Data tracking.xlsx")
CopyData
Set objExcel = Nothing
Set objWorkbook = Nothing
'---------------CopyData - Copies required data-----------------
Sub CopyData()
strTIN = "2-123456789-00005"
strName = "Smith John "
strState = "MN"
strEmpID = "S987654321"
strRecDate = "04/02/2015"
strComment = "This is all that is in my comment."
strLName = Trim(Left(strName, 10))
strFName = Trim(Right(strName, 15))
strName = strLName & " " & strFName
objExcel.Visible = True
objWorkbook.Sheets(1).Activate
objWorkbook.Sheets(1).Cells(1, 1).Value = strTIN
objWorkbook.Sheets(1).Cells(1, 2).Value = strName
objWorkbook.Sheets(1).Cells(1, 3).Value = strState
objWorkbook.Sheets(1).Cells(1, 4).Value = strEmpID
objWorkbook.Sheets(1).Cells(1, 5).Value = strRecDate
objWorkbook.Sheets(1).Cells(1, 6).Value = strComment
objExcel.ActiveWorkbook.Close
End Sub
Any ideas will be greatly appreciated.
By 'no data prints', I'm assuming that you mean the data you input is not stored. This is because you are not saving the workbook as you close it. Change one line in the sub to:
objExcel.ActiveWorkbook.Close true
See Workbook.Close Method (Excel) for full syntax reference.