I have some code here that makes you save all the sheets in a workbook as CSVs. Can anyone help me figure out a way for this code to open only sheet 3 "Sheet3" and save it as a CSV?
Private Sub CommandButton22_Click() 'Save as CSV
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.Worksheets
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
End Sub
as Raystafarian mentioned, here's the code
For Each WS In ThisWorkbook.Worksheets
If WS.name= "Sheet3" then
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
End If
Next
Replace
For Each WS In ThisWorkbook.Worksheets
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
Next
with
ThisWorkbook.Sheets("sheet3").SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
Related
Me again , I'm trying to code for spliting sheets in the xlsm file into the seperate sheet then save them in the same place with the xlsm file. the code as below:
Sub splitsheet()
Dim path As String
Dim cities
ReDim cities(1 To ThisWorkbook.Worksheets.Count)
Dim i As Long
Dim sh As Worksheet
path = ActiveWorkbook.path
For i = 1 To Worksheets.Count
cities(i) = Sheets(i).Name
ActiveWorkbook.SaveAs _
Filename:=path & "\" & Sheets(i).Name & ".xlsx"
'ActiveWorkbook.Close False
Next i
End Sub
The error in my photo below. Why it can not save as in "xlsx" extension , above code is work fine with "xlsm" extension
Filename:=path & "\" & Sheets(i).Name & ".xlsm" 'it can work fine with xlsm extension
My question is how can save as in "xlsx" extension in this case. All assist/explaination will be appriciated.
Please try this code.
Sub EachSheetToEachOwnWorkbook()
' 286
Dim Path As String
Dim Ws As Worksheet
Application.ScreenUpdating = False
Path = ThisWorkbook.Path & "\"
For Each Ws In ThisWorkbook.Worksheets
Ws.Copy
With ActiveWorkbook
.SaveAs Filename:=Path & Ws.Name & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
.Close
End With
Next Ws
Application.ScreenUpdating = True
End Sub
I have the following VBA code, to go through all the excel files in a folder and copy the needed columns from all file to one. Here is the code:
Option Explicit
Const FOLDER_PATH = "C:\Users\user\Desktop\04. April 2018\"
Sub ImportIncidentWorksheets()
Dim sFile As String
Dim wsTarget As Worksheet
Dim wbsource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long
Dim rowSource As Long
rowTarget = 2
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
On Error GoTo errHandler
Application.ScreenUpdating = True
Set wsTarget = Sheets("SC")
sFile = Dir(FOLDER_PATH & "*.xlsx*")
Do Until sFile = ""
Set wbsource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbsource.Worksheets("sheet1")
With wsSource
rowSource = Application.Max(.Range("A" & .Rows.Count).End(xlUp).Row, .Range("B" & .Rows.Count).End(xlUp).Row, .Range("C" & .Rows.Count).End(xlUp).Row, .Range("D" & .Rows.Count).End(xlUp).Row, .Range("E" & .Rows.Count).End(xlUp).Row)
End With
With wsTarget
.Range("A" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:E" & rowSource).Value
.Range("A" & rowTarget & ":C" & rowTarget + rowSource - 2).Value = wsSource.Range("A2:C" & rowSource).Value
.Range("D" & rowTarget & ":D" & rowTarget + rowSource - 2).Value = wsSource.Range("E2:E" & rowSource).Value
.Range("E" & rowTarget & ":E" & rowTarget + rowSource - 2).Value = wsSource.Range("D2:D" & rowSource).Value
.Range("F" & rowTarget).Value = wbsource.Name
End With
wbsource.Close SaveChanges:=False
rowTarget = rowTarget + rowSource - 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
Set wsSource = Nothing
Set wbsource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
How can I modify the first part that the path of the folder won't be hard coded but it will give me a pop up window and I can choose the folder manually?
You can use code like below to get path while running the code.
Dim strFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count <> 0 Then
strFolderPath = .SelectedItems(1)
Else
MsgBox "Path not selected!", vbExclamation
End If
End With
I have multiple Timesheet workbooks set up which has Employee Name and multiple columns for different hour types (eg. Base Hours, Holiday Pay, Sick Pay). See image .
I need code to be able to copy for each employee the type of hours (heading) and the value into 4 columns.
eg.
Employee 1 Base Hours 37.50
Employee 1 Sick Hours 15.00
Employee 1 Group Leader 20.00
Employee 2 Base Hours 50.00
Employee 2 Holiday Pay 60.00
I have some code which copies the data to a template currently but stuck on how to copy it as above.
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
wb.Sheets("Timesheet").Range("A9:N" & Range("A" &
Rows.Count).End(xlUp).Row).Copy
Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport").Range("A"
& Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
NewBook.Close savechanges:=True
End Sub
Example Timesheet File
Example Upload Template
Using the function at the link I posted, something like this (untested):
Option Explicit
Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook
folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Dim rngData, p, shtDest As Worksheet
Set shtDest = Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
'<edited> range containing your data
With wb.Sheets("Timesheet")
Set rngData = .Range("A9:N" & _
.Range("A" & .Rows.Count).End(xlUp).Row)
End with
'</edited>
p = UnPivotData(rngData, 2, True, False) '<< unpivot
'put unpivoted data to sheet
With shtDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
.Resize(UBound(p, 1), UBound(p, 2)).Value = p
End With
Workbooks(Filename).Close True
Filename = Dir
Loop
Application.ScreenUpdating = True
FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")
Set NewBook = Workbooks.Add
ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)
If Dir(FPath & "\" & FName) <> "" Then
MsgBox "File " & FPath & "\" & FName & " already exists"
Else
NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
NewBook.Close savechanges:=True
End Sub
I know i should probably be doing this in access or VB but I dont know how to use either. At the moment I have a submit button at the end of my form that saves and closes the workbook as whatever is inputted to a certain cell.
I am looking for a way to be able to do the same thing but break the worksheet out of the workbook. So it saves just the worksheet as its own excel file and with the name inputted into a certain cell. Below is the macro I am currently using.
Sub Saveworkbook()
Application.DisplayAlerts = False
Dim dName$, vName$
dName = Range("B8")
vName = ActiveWorkbook.FullName
ActiveWorkbook.SaveAs "W:\Test\" & dName
ActiveWorkbook.SaveAs vName
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
It would also be cool if it could add the date and computers user in to save name but not essential.
Thanks in advance
Sam
Something like this -
Sub SaveSheet()
Dim wbkDashboard As Workbook
Dim wsTarget As Worksheet
Set wsTarget = Thisworkbook.worksheets("Sheet1")
Dim strFileName As String
strFileName = wsTarget.Range("B8").Value _
& Format(Now, "ddmmyyyy") & "-" & Environ("username") & ".xlsx"
Set wbkDashboard = Workbooks.Add
wsTarget .Copy Before:=wbkDashboard.Sheets(1)
For intSheetCount = 2 To wbkDashboard.Sheets.Count
wbkDashboard.Sheets(2).Delete
Next
wbkDashboard.SaveAs "W:\Test\" & wsTarget.Range("B8").Value _
& Format(Now, "ddmmyyyy") & "-" & Environ("username") & ".xlsx"
wbkDashboard.Close
wsTarget.Range("B8").Value= strFileName
Set wsTarget = Nothing
Set wbkDashboard = Nothing
End Sub
This code will save any changes you have created in the current version, then it will save just the Active Sheet as a new workbook with the username and date (Credit to #Will on the Environment Variables).
Sub Saveworkbook()
Application.DisplayAlerts = False
Dim Sheet1 As Worksheet
Dim dName$, vName$, sName$
dName = Range("B8")
vName = ActiveWorkbook.FullName
sName = ActiveWorkbook.ActiveSheet.Name
For Each Sheet1 In ActiveWorkbook.Sheets
If Not Sheet1.Name = sName Then
Sheet1.Delete
End If
Next Sheet1
ActiveWorkbook.SaveAs "W:\Test\" & dName & "_" & Environ("username") & "_" & Format(Now, "ddmmyy") & "xlsx"
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Say I have a function that generates some data into cells into the current worksheet like :
Cells(1, "A").Value = ...
Cells(2, "A").Value = ...
Cells(3, "A").Value = ...
Cells(4, "A").Value = ...
Instead of the being the current worksheet in the current workbook, I want to create and load it into a csv file, to a give path
Say C:\USERS\Documents\Sample.csv.
I've seen stuff like
ActiveWorkbook.SaveAs Filename:= _
"c:\MyFile.csv", FileFormat:=xlCSV _
, CreateBackup:=False
But this will just save the current workbook to another location, but I don't want to generate data in the current worksheet and then save, rather I want to export right away? Is there anyway I can do that. Maybe making like ActiveWorkbook = //pathname and then Activating it ?
You can write to a CSV quite simply using VBA.
An example could be:
Sub WriteCSVFile()
Dim My_filenumber As Integer
Dim logSTR As String
My_filenumber = FreeFile
logSTR = logSTR & Cells(1, "A").Value & " , "
logSTR = logSTR & Cells(2, "A").Value & " , "
logSTR = logSTR & Cells(3, "A").Value & " , "
logSTR = logSTR & Cells(4, "A").Value
Open "C:\USERS\Documents\Sample.csv" For Append As #My_filenumber
Print #My_filenumber, logSTR
Close #My_filenumber
End Sub
Use the .move to make a new book of the target sheet, then .saveas the newly created book as a CSV. Adjust the Pathname to adjust the directory where you want your csv saved.
Pathname = "" & Thisworkbook.path & "YourName.csv"
Sheets("Sheet you want as CSV").Move
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
Just modified the code by #CharlieSmith to a fairly simple and more usable code, which will convert all the sheets in your workbook to new csv files named with respective sheet names.
Sub WriteCSVFile()
Dim i As Integer
Dim WS_Count As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(i)
PathName = "" & ThisWorkbook.Path & "\" & ws.Name & ".csv"
ws.Copy
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
Next i
End Sub
Hope this helps