This is as far as I got with it however it is now only copying the active.sheet multiple times rather than cycling through.
The idea of what I was trying to achieve was for a macro to run and covert every worksheet as a .csv. The filename of that .csv would be the worksheet name which is decided by another macro than runs earlier in the flow.
Any ideas on how to circle through, as I said before. I am fairly new to code hence why I am asking.
Sub Export_Sub_Xpath()
'
' Export_Sub_Xpath Macro
'
Dim i As Integer
Dim WS_Count As Integer
Dim ws As Worksheet
WS_Count = ActiveWorkbook.Worksheets.Count
For i = 1 To WS_Count
Set ws = ThisWorkbook.Worksheets(i)
PathName = "" & ActiveWorkbook.Path & "\" & ws.Name & ".csv"
Columns("A:B").Select
Range("B3000").Activate
Selection.Copy
PathName = "" & ActiveWorkbook.Path & "\" & ws.Name & ".csv"
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
'ActiveWorkbook.SaveAs PathName = "" & ActiveWorkbook.Path & "\" & ws.Name & ".csv"
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next i
End Sub
You forgot to activate each sheet before copying and saving. Try this:
Sub Export_Sub_Xpath() ' ' Export_Sub_Xpath Macro '
Dim i As Integer
Dim WS_Count As Integer
Dim ws As Worksheet
WS_Count = ThisWorkbook.Worksheets.Count
For i = 1 To WS_Count
Set ws = ThisWorkbook.Worksheets(i)
PathName = "" & ThisWorkbook.Path & "\" & ws.Name & ".csv"
ThisWorkbook.Worksheets(i).Activate ' You forgeot to Activate Each Sheet before saving
Columns("A:B").Select
Range("B3000").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.SaveAs Filename:=PathName, _
FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next i
End Sub
Related
I'm trying to save as my Excel file into multiple xlsx files, soemthing like this:
I would like to save as it into multiple xlsx files with each file will content 1 line range("Ax:Dx"). I have written the code as below to do that
Sub split_file()
Dim wb As Workbook
Dim ws As Worksheet
Dim i As Long
Dim lastrow1 As Long
Dim lastrow2 As Long
Set wb = ThisWorkbook
On Error Resume Next
'Dim filename As String
Path = "C:\test"
For i = 2 To Sheet2.Range("A" & Rows.Count).End(xlUp).Row
'wb.Worksheets(3).Copy 'create new active workbook
Sheets.Add.Name = Sheet2.Range("A" & i).Value
With Worksheets(Sheet2.Range("A" & i).Value)
Range("A1:D1").Value = Sheet2.Range("A" & i & ":D" & i).Value
.SaveAs filename:=Path & "\" & Sheet2.Range("A" & i).Value, FileFormat:=xlOpenXMLWorkbook, Password:="Welcome1"
.Close savechanges:=False
End With
Next i
On Error GoTo 0
End Sub
The result I got is shown in this screenshot:
Once I open the file after save as with proper data, it include some unwanted sheets in that :( .
Like this:
I wish it save as only the file with the same name. Can anybody help look for this problem ?
Very appreciated for each support of you all.
Please, try the next way:
Sub split_file()
Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet, wbNew As Workbook
Dim path As String, i As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(Sheet2.Name)
path = "C:\test"
For i = 2 To ws.Range("A" & rows.count).End(xlUp).row
Set wbNew = Workbooks.Add(xlWBATWorksheet)
Set wsNew = wbNew.Sheets(1): wsNew.Name = ws.Range("A" & i).value
wsNew.Range("A1:D1").value = ws.Range("A" & i & ":D" & i).value
wbNew.saveas FileName:=path & "\" & wsNew.Name, FileFormat:=xlOpenXMLWorkbook, password:="Welcome1"
wbNew.Close savechanges:=False
Next i
End Sub
I assumed that Sheet2 is a code name...
as the title suggests, I'm trying to export sheets (starting from the fourth sheet and beyond, this is a fixed value) to separate CSV files. Ideally it would be right into a folder on the desktop containing each files. Below is the code I've been working with / trying to tweak-
Sub ExportSheetsToCSV()
Dim xWs As Worksheet
Dim xcsvFile As String
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.Copy
xcsvFile = CurDir & "\" & xWs.Name & ".csv"
Application.ActiveWorkbook.SaveAs Filename: = xcsvFile, _
FileFormat: = xlCSV, CreateBackup: = False
Application.ActiveWorkbook.Saved = True
Application.ActiveWorkbook.Close
Next
End Sub
Use the worksheets collection index.
Sub ExportSheetsToCSV()
Dim xWs As Worksheet
Dim xcsvFile As String, w as long
For w=4 to ActiveWorkbook.Worksheets.count
with ActiveWorkbook.Worksheets(w)
xcsvFile = CurDir & "\" & .Name & ".csv"
.Copy
with ActiveWorkbook
.SaveAs Filename:=xcsvFile, FileFormat:=xlCSV
.Close savechanges:=false
end with
end with
Next w
end sub
Is CurDir appropriate here? ActiveWorkbook.Path may be another option.
I have a code that copies two worksheets from one workbook to a new one.
Since those two worksheets contain graphs where the data is on the sheet itself, but the datacells refer to a different worksheet, I copy the values only, to avoid external links.
However I found out that there is still an external link to my original workbook.
I don't know where it is though, since there are no formulas anymore.
I thought about names and deleted them as well, since there were a lot of names, that didn't even exist in the original file. That didn't help either.
I can delete the external, when using the menu in the ribbon.
And the code below also works, when I use it in the new workbook itself when opening it and running it in there.
Sub BreakLinks()
Dim wb As Workbook
Set wb = Application.ActiveWorkbook
If Not IsEmpty(wb.LinkSources(xlExcelLinks)) Then
For Each link In wb.LinkSources(xlExcelLinks)
wb.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
End Sub
However, if I want to use that code in conjunction with the copying, it does not do the trick. I saved it on purpose before breaking the link, because I thought it might not be able to do it, but it didn't help.
Does anybody know why it doesn't work or can point me to a solution?
Here's the complete code:
Sub ACTION_Export_Capex()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim wb As Workbook
Pfad = "D:\#Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "monthly Report-" & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy-mm") & " Capex" & ".xlsx"
'Copy Sheets without formulas
Sheets(Array("Capex_monthly", "Capex_YTD")).Copy
For Each ws In Worksheets
ws.UsedRange = ws.UsedRange.Value
Next
'get rid of macrobuttons and hyperlinks
For Each ws In Worksheets
ws.Rectangles.Delete
ws.Hyperlinks.Delete
Next
ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
'delete external links
If Not IsEmpty(ActiveWorkbook.LinkSources(xlExcelLinks)) Then
For Each link In ActiveWorkbook.LinkSources(xlExcelLinks)
ActiveWorkbook.BreakLink link, xlLinkTypeExcelLinks
Next link
End If
ActiveWorkbook.Save
ActiveWorkbook.Close
'go back to main menu in Cockpit
Sheets("Menu").Select
End Sub
Thanks a lot in advance.
EDIT:
In the end brettdj got the solution, I just had to tweak it a bit to get it done in my workbook.
Here's the code:
Sub ACTION_Export_Capex()
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
Dim wb As Workbook
Pfad = "D:\#Inbox\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "monthly Report-" & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy-mm") & " Capex" & ".xlsx"
'Copy Sheets without formulas
Sheets(Array("Capex_monthly", "Capex_YTD")).Copy
For Each ws In Worksheets
ws.UsedRange = ws.UsedRange.Value
Next
'get rid of macrobuttons and hyperlinks
For Each ws In Worksheets
ws.Rectangles.Delete
ws.Hyperlinks.Delete
Next
'get rid of external link
ActiveWorkbook.ChangeLink ThisWorkbook.Name, ActiveWorkbook.Name, xlLinkTypeExcelLinks
ActiveWorkbook.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close
Sheets("Menu").Select
End Sub
If I use this code the links are gone when the new worbook is opened again.
I am still puzzled why the original creation builds in a phantom link that exists even when the two copied sheets are deleted.
code
Sub Test()
Dim wb As Workbook
Dim wb2 As Workbook
Dim Pfad As String
Dim Dateiname As String
Dim ws As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = falser
End With
Pfad = "D:\#Inbox\"
'Pfad = "c:\temp\"
Dateiname = Format(Date, "YYYY-MM-DD") & " " & Format(Time, "hhmm") & " " & "monthly Report-" & Format(DateSerial(Year(Date), Month(Date) - 1, 1), "yyyy-mm") & " Capex" & ".xlsx"
Set wb = ThisWorkbook
Set wb2 = Workbooks.Add(1)
wb.Sheets(Array("Capex_monthly", "Capex_YTD")).Copy After:=wb2.Sheets(1)
wb2.Sheets(1).Delete
wb2.SaveAs Filename:=Pfad & Dateiname, FileFormat:=xlOpenXMLWorkbook
wb2.ChangeLink wb.Name, wb2.Name, xlLinkTypeExcelLinks
wb2.Close
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.Goto wb.Sheets("Menu").[a1]
End With
Set wb2 = Workbooks.Open(Pfad & Dateiname)
End Sub
I have found a decent solution Saving excel worksheet to CSV files with filename+worksheet name using VB for saving all worksheets in a workbook as CSV files. However, I would like to be able to modify this code to only save worksheets where the sheet name ends with _t.
I am using the following code:
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.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
' Temporarily turn alerts off to prevent the user being prompted
' about overwriting the original file.
End Sub
Can this be done?
Use the Right or Instr-Method on the worksheet.name property to get the last characters / check if your searchstring is exisiting.
In your for each-loop add the following code:
If Right(WS.name, 2) = "_t" Then
Sheets(WS.Name).Copy
ActiveWorkbook.SaveAs Filename:=SaveToDirectory & ThisWorkbook.Name & "-" & WS.Name & ".csv", FileFormat:=xlCSV
ActiveWorkbook.Close savechanges:=False
ThisWorkbook.Activate
End if
Based on some other stuff I found here, I have made the following script to do almost exactly what I want. It will export all but 4 specific sheets in an excel file to CSV files, append dates to them, and save them to dated folders. The only problem is it renames the sheets it exported in the original processing file. How can I rectify this?
Sub SaveLCPWorksheetsAsCsv()
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 = "C:\test\" & Format(Date - 1, "YYYYMM") & "\"
If Len(Dir(SaveToDirectory, vbDirectory)) = 0 Then
MkDir SaveToDirectory
End If
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> "Input" And WS.Name <> "Ref" And WS.Name <> "Total" And WS.Name <> "Affected Accounts" Then
WS.SaveAs SaveToDirectory & WS.Name & "_" & Format(Date - 1, "YYYYMMDD"), xlCSV
End If
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
Sub Tester()
Dim ws As Worksheet, wb As Workbook
For Each ws In ThisWorkbook.Worksheets
ws.Copy 'creates a new workbook
With ActiveWorkbook
.SaveAs "C:\temp\" & ws.Name & "_blah.csv", xlCSV
.Close False
End With
Next ws
End Sub