I am trying to create multiple csv files from excel. I have a vba that creates a csv file per tab however there are blanks in the output.
I have 6 columns that the csv file returns is there a way for me to ignore blank cells so I don't have blank commas eg " , , "
Here is the code I am using:
Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
Dim CurrentWorkbook As String
Dim CurrentFormat As Long
CurrentWorkbook = ThisWorkbook.FullName
CurrentFormat = ThisWorkbook.FileFormat
' Store current details for the workbook
SaveToDirectory = "H:\test\"
For Each WS In ThisWorkbook.Worksheet
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Next
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
Application.DisplayAlerts = True
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
Thanks Joe
Blank cells can be found with Selection.SpecialCells(xlCellTypeBlanks).Select, but I don't see you selecting any data.
If you only need certain columns, I would suggest you remove other columns after copying to your new sheet. Add this line after your Copy:
ActiveSheet.Columns(X).Delete
Do this for each column you want to delete, replacing X with the name of the column, ie. "C".
Related
As pre-warning, I am new to using VBA.
I have scraped together the following code to do the following:
1. Locate the worksheet "Intrastat"
2. Copy the used range of this worksheet
3. Paste as values into a new workbook
4. Reformat dates in column B
5. Save the workbook with in the original workbook's location.
However this only works when I have the macro saved in the original workbook. What I need is to be able to have the macro saved in a different workbook and on running the macro I need to be able to select the "original" workbook from a file location on my HDD.
Any ideas?
The Current Code:
Sub TB_Intrastat_Data_Cleanse()
Dim wb As Workbook
Set wb = Workbooks.Add
Set TWKB = ThisWorkbook
Set sel = Selection
Dim folderPath As String
folderPath = Application.ThisWorkbook.Path
TWKB.Sheets("Intrastat").UsedRange.Copy
wb.Sheets(1).[a1].PasteSpecial xlPasteValues
Columns("B:B").Select
Selection.NumberFormat = "dd/mm/yyyy;#"
nme = "TB Intrastat Data " & Range("A3") & " MTD"
ActiveWorkbook.SaveAs Filename:=folderPath & nme
End Sub
You can use Application.GetOpenFilename() to prompt the user to browse through the file explorer, and open a file. It will then use that file as TWKB:
Sub TB_Intrastat_Data_Cleanse()
Dim wb As Workbook, TWKB As Workbook
Dim sel As Range
Dim nme As String
Set wb = Workbooks.Add
Set TWKB = Application.GetOpenFilename(Title:="Please choose a file to open", FileFilter:="Excel Files *.xls* (*.xls*),")
Set sel = Selection
Dim folderPath As String
folderPath = Application.ThisWorkbook.Path
TWKB.Sheets("Intrastat").UsedRange.Copy
wb.Sheets(1).[a1].PasteSpecial xlPasteValues
Columns("B:B").NumberFormat = "dd/mm/yyyy;#"
nme = "TB Intrastat Data " & Range("A3") & " MTD"
ActiveWorkbook.SaveAs Filename:=folderPath & nme
End Sub
Note: I would change ActiveWorkbook.SaveAs at the end to a workbook variable (or explicitly name the workbook), since you're using two separate ones you want to make sure it's saving the correct one.
having a bit of an infuriating time dealing with Excel 2013 and I can't seem to find any answers which give me what I need.
I've written some simple VBA which generates a number of dummy data tables, the output is generating absolutely fine, and the formats appear to be correct in the output table prior to export.
However, the element that I'm having difficulty with is when I export the files using VBA into CSV (they need to be uploaded into SQL Server). The export itself works fine, but when I try to re-open the file in Excel the data types in my date columns are 'garbled'. I'm in the UK, and computer is set up as such, but Excel appears to be converting these to a US format, meaning that some are 'date' (any string which would fit a UK format), others are 'general' which would obviously cause issues when uploading to SQL Server.
I've tried manually copying the data tabs, and saving them as CSV. When I do this, I can open them and the date format is absolutely fine. I can only assume therefore that it's something to do with my export, any thoughts would be greatly appreciated.
Code is as below:
Sub exportdata()
wdir = ThisWorkbook.Path
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Save sheets which aren't the command sheet.
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "Command" Then
Application.StatusBar = "Exporting sheet " & sht.Name
sht.Copy
Application.ActiveWorkbook.SaveAs wdir & "\Generated\" & sht.Name & ".csv", xlCSVWindows
Application.ActiveWorkbook.Close False
End If
Next
Application.StatusBar = ""
Does anybody have any ideas? Appreciate I can just manually export each tab, but that's incredibly annoying and I'll be needing to run this quite a few times.
Note - I've tried using xlCsv and xlCsvWindows, and the same thing happens.
I encountered the same issue.
The only way I know to avoid this is to open Excel and open the file from Excel.
When the file is opened a screen is popping up and Excel wants to know from the user how the data needs to be opened.
What I usually do is in the 3 screen to select all column and define them as text. This also prevents you from losing leading zero's (if applicable). This way in Excel numbers are as text (you can't calculate with them, but SAP for example doesn't mind to upload numbers as text. :) )
How about looping through your date range before saving as CSV, such as below:
Sub exportdata()
Dim c As Range
Dim sht As Worksheet
Dim LastRow As Long
wdir = ThisWorkbook.Path
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Save sheets which aren't the command sheet.
For Each sht In ThisWorkbook.Sheets
If sht.Name <> "Command" Then
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
For Each c In sht.Range("A1:A" & LastRow) 'loop through column A to format dates
c.Value = Format(c, "dd/mm/yyyy")
Next c
Application.StatusBar = "Exporting sheet " & sht.Name
'sht.Copy
Application.ActiveWorkbook.SaveAs wdir & "\Generated\" & sht.Name & ".csv", xlCSVWindows
Application.ActiveWorkbook.Close False
End If
Next
Application.StatusBar = ""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I have no idea if this will work (and can't test it because I live in the US), but one idea is to Copy/PasteSpecial the values in each sheet rather than copying the sheets directly.
Sub exportData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
If Not ws.Name = "Command" Then
Application.StatusBar = "Exporting sheet " & ws.Name
Call createTextFile(ws.UsedRange, ws.Parent.Path & "\Generated\", ws.Name & ".csv", xlCSV)
End If
Next
Application.StatusBar = ""
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sub createTextFile(sourceRng As Range, fPath As String, fName As String, fFormat As Variant)
Dim wb As Workbook
Set wb = Workbooks.Add
sourceRng.Copy
With wb.Sheets(1)
.Range(.Cells(1, 1), .Cells(sourceRng.Rows.Count, sourceRng.Columns.Count)).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = False
wb.SaveAs Filename:=fPath & fName, FileFormat:=fFormat
wb.Close
End Sub
If that doesn't work, I'd be curious to see if the issue is only with files with the .csv extension; you could test a .txt file by changing this line:
Call createTextFile(ws.UsedRange, ws.Parent.Path & "\Generated\", ws.Name & ".csv", xlCSV)
To this one:
Call createTextFile(ws.UsedRange, ws.Parent.Path & "\Generated\", ws.Name & ".txt", xlText)
As a last resort, you may be able to separate the day/month/year into separate columns, then modify your SQL script to combine them as it updates the tables. Something like this:
CREATE TABLE #temptbl
(
dtyear int,
dtmonth int,
dtday int,
dtdate AS (DATEFROMPARTS(dtyear, dtmonth, dtday)),
empid varchar(8),
hrsworked int
);
BULK INSERT #temptbl
FROM '\\yourpath\uploadfile.txt'
WITH
(
FIELDTERMINATOR = '\t',
ROWTERMINATOR = '\n'
);
MERGE dbo.emphours AS target
USING #temptbl AS source
ON
(target.empid = source.empid) AND
(target.dtdate = source.dtdate)
WHEN MATCHED AND (target.hrsworked <> source.hrsworked) THEN
UPDATE SET
target.hrsworked = source.hrsworked
WHEN NOT MATCHED BY target THEN
INSERT
(dtdate,empid,hrsworked)
VALUES
(source.dtdate,source.empid,source.hrsworked);
DROP TABLE #tempHH;
I have a VBA macro which allows me to export in CSV (using the comma as separator) some sheets of my excel file, in this case, first 7 sheets. I have following problems:
The code allows to export first 1 - n sheets, but I would like to put the code to select sheets by name. In this case I could also export the sheet 1, called "MILANO" and the sheet 5, called "ROME".
I cannot find the way to save the CSV files automatically in the same folder of the source excel file. I used ActiveWorkbook.Path or ThisWorkbook.Path, but I guess I wrong something
I cannot export only rows of each sheet not-empty as in the CSV I see hundreds of rows with ,,,,,,,,,
Here the macro:
Sub CreateCSV()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'-----------------------------
'DECLARE AND SET VARIABLES
Dim wb1 As Workbook, ws1 As Worksheet
Dim wbname As String, I As Integer
Set wb1 = ThisWorkbook
'-----------------------------
'CYCLE THROUGH SHEETS AND MATCH UPLOAD
For I = 1 To 7
wbname = Worksheets(I).Name
'-----------------------------
'COPY SHEET INTO NEW CSV FILE
Worksheets(I).Copy
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "/" & wbname & "/.csv", _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
wb1.Activate
Next I
'-----------------------------
'CLEANUP
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Thanks!
try this for your point 2
ActiveWorkbook.SaveAs Filename:=wb1.Path & "\" & wbname & ".csv", _
With regards to accessing you sheets by name you can do this,
set sh = ThisWorkBook.Sheets("MILANO")
but since you would want to loop through your sheets anyway, you need have an array with you sheet names like so,
Dim mySheets as Variant
Dim sh as WorkSheet
Dim I as Long
mySheets=Array("MILANO" , "MONACO", "ROME")
For I = 0 to UBound(mySheets)
Set sh = ThisWorkBook.Sheets(mySheets(I))
sh.SaveAs FileName:=ThisWorkBook.Path & "\" & mySheets(I), _
FileFormat:=xlCSV
Next I
So you need to use the WorkSheet.SaveAs and not the WorkBook.SaveAs
as far as "I cannot export only rows of each sheet not-empty as in the CSV I see hundreds of rows with ,,,,,,,,," Perhaps you need to cleanup the Worksheet first
I am trying to create a duplicate button on the excel ribbon which when clicked, will create a duplicate file of the active workbook but I want it to create a duplicate file having only first two sheets copied in the duplicate file and not the whole active workbook.
I tried the below code for getting the duplicate file :
Sub DupliquerFeuille(control As IRibbonControl)
Dim Sourcewb As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
'Copy the sheet to a new workbook
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & ActiveWorkbook.Name
ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & nom
' ActiveWorkbook.Sheets(Array(1, 2)).Copy
End Sub
But I am getting all sheets of active workbook copied in the duplicate file. Can anyone please help me in getting only the first sheets of active workbook copied in the duplicate file. I tried a lot but I am unable to get the result.
Try this:
Sub DupliquerFeuille(control As IRibbonControl)
Dim twb As Workbook
Dim Sourcewb As Workbook
Const shc As Long = 2 ' change this as you need, this will copy first 2 sheets
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Sourcewb.Sheets(1).Copy
Set twb = ActiveWorkbook
For i = 2 To shc
Sourcewb.Sheets(i).Copy ,twb.Sheets(twb.Sheets.Count)
Next
nom = Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & Sourcewb.Name
twb.SaveAs Sourcewb.Path & "\" & nom, Sourcewb.FileFormat
twb.Close False
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
How about just adding an extra few lines of code after you save the new workbook to delete out those pages you don't like?
Such as
Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Replace "Sheet 1" with the name of the sheet (keep the quotation marks)
Below code lines find the path and name of current excel file, copy the first two sheets and save to a new (duplicated) workbook in the same location as the main workbook:
Set Sourcewb = ActiveWorkbook
' Create path and name for export
PathName = ThisWorkbook.Path & "_export"
' Copy the sheets so they don't get removed in the main file
Sheets(Array(1, 2)).Copy Before:=Sheets(1)
' Move the first two sheets to a new workbook
Sheets(Array(1, 2)).Move
' Save the active duplicated workbook
ActiveWorkbook.SaveAs Filename:=PathName, FileFormat:=Sourcewb.FileFormat
' Close the active duplicated workbook
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
I have 1 WorkBook("SOURCE") that contains around 20 Sheets.
I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA.
Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.
Methods Used -
1) Activeworkbook.SaveAs <--- Doesn't work. This will copy all the sheets. I want only specific sheet.
I have 1 WorkBook("SOURCE") that contains around 20 Sheets. I want to copy only 1 particular sheet to another Workbook("TARGET") using Excel VBA. Please note that the "TARGET" Workbook doen't exist yet. It should be created at runtime.
Another Way
Sub Sample()
'~~> Change Sheet1 to the relevant sheet
'~~> This will create a new workbook with the relevant sheet
ThisWorkbook.Sheets("Sheet1").Copy
'~~> Save the new workbook
ActiveWorkbook.SaveAs "C:\Target.xlsx", FileFormat:=51
End Sub
This will automatically create a new workbook called Target.xlsx with the relevant sheet
To copy a sheet to a workbook called TARGET:
Sheets("xyz").Copy After:=Workbooks("TARGET.xlsx").Sheets("abc")
This will put the copied sheet xyz in the TARGET workbook after the sheet abc
Obviously if you want to put the sheet in the TARGET workbook before a sheet, replace Before for After in the code.
To create a workbook called TARGET you would first need to add a new workbook and then save it to define the filename:
Application.Workbooks.Add (xlWBATWorksheet)
ActiveWorkbook.SaveAs ("TARGET")
However this may not be ideal for you as it will save the workbook in a default location e.g. My Documents.
Hopefully this will give you something to go on though.
You can try this VBA program
Option Explicit
Sub CopyWorksheetsFomTemplate()
Dim NewName As String
Dim nm As Name
Dim ws As Worksheet
If MsgBox("Copy specific sheets to a new workbook" & vbCr & _
"New sheets will be pasted as values, named ranges removed" _
, vbYesNo, "NewCopy") = vbNo Then Exit Sub
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("Sheet1", "Sheet2")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook", "New Copy")
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewName & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
The much longer example below combines some of the useful snippets above:
You can specify any number of sheets you want to copy across
You can copy entire sheets, i.e. like dragging the tab across, or you can copy over the contents of cells as values-only but preserving formatting.
It could still do with a lot of work to make it better (better error-handling, general cleaning up), but it hopefully provides a good start.
Note that not all formatting is carried across because the new sheet uses its own theme's fonts and colours. I can't work out how to copy those across when pasting as values only.
Option Explicit
Sub copyDataToNewFile()
Application.ScreenUpdating = False
' Allow different ways of copying data:
' sheet = copy the entire sheet
' valuesWithFormatting = create a new sheet with the same name as the
' original, copy values from the cells only, then
' apply original formatting. Formatting is only as
' good as the Paste Special > Formats command - theme
' colours and fonts are not preserved.
Dim copyMethod As String
copyMethod = "valuesWithFormatting"
Dim newFilename As String ' Name (+optionally path) of new file
Dim themeTempFilePath As String ' To temporarily save the source file's theme
Dim sourceWorkbook As Workbook ' This file
Set sourceWorkbook = ThisWorkbook
Dim newWorkbook As Workbook ' New file
Dim sht As Worksheet ' To iterate through sheets later on.
Dim sheetFriendlyName As String ' To store friendly sheet name
Dim sheetCount As Long ' To avoid having to count multiple times
' Sheets to copy over, using internal code names as more reliable.
Dim colSheetObjectsToCopy As New Collection
colSheetObjectsToCopy.Add Sheet1
colSheetObjectsToCopy.Add Sheet2
' Get filename of new file from user.
Do
newFilename = InputBox("Please Specify the name of your new workbook." & vbCr & vbCr & "Either enter a full path or just a filename, in which case the file will be saved in the same location (" & sourceWorkbook.Path & "). Don't use the name of a workbook that is already open, otherwise this script will break.", "New Copy")
If newFilename = "" Then MsgBox "You must enter something.", vbExclamation, "Filename needed"
Loop Until newFilename > ""
' If they didn't supply a path, assume same location as the source workbook.
' Not perfect - simply assumes a path has been supplied if a path separator
' exists somewhere. Could still be a badly-formed path. And, no check is done
' to see if the path actually exists.
If InStr(1, newFilename, Application.PathSeparator, vbTextCompare) = 0 Then
newFilename = sourceWorkbook.Path & Application.PathSeparator & newFilename
End If
' Create a new workbook and save as the user requested.
' NB This fails if the filename is the same as a workbook that's
' already open - it should check for this.
Set newWorkbook = Application.Workbooks.Add(xlWBATWorksheet)
newWorkbook.SaveAs Filename:=newFilename, _
FileFormat:=xlWorkbookDefault
' Theme fonts and colours don't get copied over with most paste-special operations.
' This saves the theme of the source workbook and then loads it into the new workbook.
' BUG: Doesn't work!
'themeTempFilePath = Environ("temp") & Application.PathSeparator & sourceWorkbook.Name & " - Theme.xml"
'sourceWorkbook.Theme.ThemeFontScheme.Save themeTempFilePath
'sourceWorkbook.Theme.ThemeColorScheme.Save themeTempFilePath
'newWorkbook.Theme.ThemeFontScheme.Load themeTempFilePath
'newWorkbook.Theme.ThemeColorScheme.Load themeTempFilePath
'On Error Resume Next
'Kill themeTempFilePath ' kill = delete in VBA-speak
'On Error GoTo 0
' getWorksheetNameFromObject returns null if the worksheet object doens't
' exist
For Each sht In colSheetObjectsToCopy
sheetFriendlyName = getWorksheetNameFromObject(sourceWorkbook, sht)
Application.StatusBar = "VBL Copying " & sheetFriendlyName
If Not IsNull(sheetFriendlyName) Then
Select Case copyMethod
Case "sheet"
sourceWorkbook.Sheets(sheetFriendlyName).Copy _
After:=newWorkbook.Sheets(newWorkbook.Sheets.count)
Case "valuesWithFormatting"
newWorkbook.Sheets.Add After:=newWorkbook.Sheets(newWorkbook.Sheets.count), _
Type:=sourceWorkbook.Sheets(sheetFriendlyName).Type
sheetCount = newWorkbook.Sheets.count
newWorkbook.Sheets(sheetCount).Name = sheetFriendlyName
' Copy all cells in current source sheet to the clipboard. Could copy straight
' to the new workbook by specifying the Destination parameter but in this case
' we want to do a paste special as values only and the Copy method doens't allow that.
sourceWorkbook.Sheets(sheetFriendlyName).Cells.Copy ' Destination:=newWorkbook.Sheets(newWorkbook.Sheets.Count).[A1]
newWorkbook.Sheets(sheetCount).[A1].PasteSpecial Paste:=xlValues
newWorkbook.Sheets(sheetCount).[A1].PasteSpecial Paste:=xlFormats
newWorkbook.Sheets(sheetCount).Tab.Color = sourceWorkbook.Sheets(sheetFriendlyName).Tab.Color
Application.CutCopyMode = False
End Select
End If
Next sht
Application.StatusBar = False
Application.ScreenUpdating = True
ActiveWorkbook.Save
Sub ActiveSheet_toDESKTOP_As_Workbook()
Dim Oldname As String
Dim MyRange As Range
Dim MyWS As String
MyWS = ActiveCell.Parent.Name
Application.DisplayAlerts = False 'hide confirmation from user
Application.ScreenUpdating = False
Oldname = ActiveSheet.Name
'Sheets.Add(Before:=Sheets(1)).Name = "FirstSheet"
'Get path for desktop of user PC
Path = Environ("USERPROFILE") & "\Desktop"
ActiveSheet.Cells.Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "TransferSheet"
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.Copy
'Create new workbook and past copied data in new workbook & save to desktop
Workbooks.Add (xlWBATWorksheet)
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells(1, 1).Select
ActiveWorkbook.ActiveSheet.Name = Oldname '"report"
ActiveWorkbook.SaveAs Filename:=Path & "\" & Oldname & " WS " & Format(CStr(Now()), "dd-mmm (hh.mm.ss AM/PM)") & ".xlsx"
ActiveWorkbook.Close SaveChanges:=True
Sheets("TransferSheet").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Worksheets(MyWS).Activate
'MsgBox "Exported to Desktop"
End Sub