I have a macro that works
Sub EXPORT_POR()
Dim wb As Workbook
Dim ws As Worksheet
Dim FileSaveName As Variant
FileSaveName = Application.GetSaveAsFilename(fileFilter:="Text (Tab delimited) (*.*), *.*")
Sheets("POR_FINAL_OU").Copy
Set wb = ActiveWorkbook
Set ws = ActiveSheet
With wb
With ws
.Range("A:C").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
.Range(.Cells(1, "C"), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
.SaveAs FileSaveName, xlTextWindows
.Close False
End With
i = MsgBox("Soubor uložen", vbOKOnly + vbInformation)
End Sub
Now I have extended the sheet with additional columns and thus logically extended the code
Sub EXPORT_POR()
Dim wb As Workbook
Dim ws As Worksheet
Dim FileSaveName As Variant
FileSaveName = Application.GetSaveAsFilename(fileFilter:="Text (Tab delimited) (*.*), *.*")
Sheets("POR_FINAL_OU").Copy
Set wb = ActiveWorkbook
Set ws = ActiveSheet
With wb
With ws
.Range("A:G").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
.Range(.Cells(1, "G"), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
.SaveAs FileSaveName, xlTextWindows
.Close False
End With
i = MsgBox("Soubor uložen", vbOKOnly + vbInformation)
End Sub
Now I get the following error when I start macro
"error 1004 - Cannot use that command on overlapping selections"
I have no idea how to fix it
i solved this way. Juste change this:
With ws
.Range("G:G").SpecialCells(xlCellTypeBlanks).EntireRow.DELETE
.Range(.Cells(1, "G"), .Cells(.Rows.Count, .Columns.Count)).Clear
End With
.SaveAs FileSaveName, xlTextWindows
.Close False
Related
The code below creates and saves all the excel sheets from "Test_Main" into separate new workbooks with file extension .xlsx and I want it to save the workbook in .csv format. Could someone please alter my current code to do the required job ? Thanks in advance :)
Sub Workbook()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook
a = ThisWorkbook.Worksheets.Count 'counts all the sheets
For i = 1 To a 'loops for all sheets
If ThisWorkbook.Worksheets(i).Name <> "Test_Main" Then 'rule out the main sheet
Set wb = Workbooks.Add
ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1) 'new workbook has 1 worksheet by deafult
wb.SaveAs "H:\IT\Melissa\Essengeld\TEST\" & ThisWorkbook.Worksheets(i).Name
wb.Close savechages = True
End If
Next i
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Activate
ThisWorkbook.Sheets(1).Cells(1, 1).Select
MsgBox ("Task Completed")
End Sub
Microsoft answer question here -> https://learn.microsoft.com/en-us/office/vba/api/excel.workbook.saveas
I took code from to export a sheet from here
Sub exportSheet(sh As Worksheet, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
sh.Copy wbNew.Sheets(1)
Set wsNew = wbNew.Sheets(1)
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
and used it in your code like that
Sub exportToCSV()
Dim a As Integer
Dim ws As Worksheet
Dim wb As Workbook
a = ThisWorkbook.Worksheets.Count 'counts all the sheets
For i = 1 To a 'loops for all sheets
If ThisWorkbook.Worksheets(i).Name <> "Test_Main" Then 'rule out the main sheet
' Set wb = Workbooks.Add
' ThisWorkbook.Worksheets(i).Copy before:=wb.Worksheets(1) 'new workbook has 1 worksheet by deafult
' wb.SaveAs "H:\IT\Melissa\Essengeld\TEST\" & ThisWorkbook.Worksheets(i).Name
'
' wb.Close savechages = True
exportSheet ThisWorkbook.Worksheets(i), "H:\IT\Melissa\Essengeld\TEST\" & ThisWorkbook.Worksheets(i).Name
End If
Next i
ThisWorkbook.Activate
ThisWorkbook.Sheets(1).Activate
ThisWorkbook.Sheets(1).Cells(1, 1).Select
MsgBox ("Task Completed")
End Sub
I found the solution:
wb.SaveAs "H:\IT\Melissa\Essengeld\TEST" & ThisWorkbook.Worksheets(i).Name , FileFormat:=xlCSV
Hey I am quite new to VBA and I am currently trying to export tables from different sheets, if there is an alternation made to it, as CSV data. Currently my code exports all tables from my file. How can I make it export only the current table that I am executing the makro on?
Thank you for your help!
Public Sub SaveWorksheetsAsCsv()
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.name, xlCSV
Next
End Sub
I figured out a way to do it but now the window opens as a CSV file. How do i close the csv file and reopen the worksheet I was working on?
Public Sub SaveWorksheetsAsCsvUndercarriageDefinition()
Dim wbk As Workbook
Dim xWs As Worksheet
Dim xDir As String
Dim folder As FileDialog
Set wbk = Workbooks("Vba_Fehlerprüfung.xlsm")
Set xWs = wbk.Worksheets("Undercarriage Definition")
Set folder =
Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> -1 Then Exit Sub
xDir = folder.SelectedItems(1)
'For Each xWs In Application.ActiveWorkbook.Worksheets
xWs.SaveAs xDir & "\" & xWs.name, xlCSV
'Next
End Sub
My suggestion would be to use the following sub in order to export a table resp. an listobject
Sub exportListobject(lo As ListObject, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
Set wsNew = wbNew.Sheets(1)
lo.Range.Copy
wsNew.Range("A1").PasteSpecial Paste:=xlPasteAll
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
It will copy the listobject in question into a new workbook, save it as an csv file and close it. The workbook which contains the listobject will not be touched.
If you want to export a single sheet from your workbook you can use a similar sub
Sub exportSheet(sh As Worksheet, csvFilename As String)
Dim wbNew As Workbook
Set wbNew = Workbooks.Add
Dim wsNew As Worksheet
With wbNew
sh.Copy wbNew.Sheets(1)
Set wsNew = wbNew.Sheets(1)
.SaveAs Filename:=csvFilename, _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
.Close False
End With
End Sub
i'm trying to export all my sheets in my workbook at once as image. The final goal should be to open the macro or press an button and then all the worksheets are exported to an directory named as "worksheet".jpg and they should have the exact same size, for example. I tried to add some extra code to this, which i found somewhere:
Sub SaveStaticImageWorkbook()
Dim ws As Worksheet, wb As Workbook, fDialog As FileDialog
Application.DisplayAlerts = False
Set wb = Workbooks.Add
wb.Sheets(1).Name = "Tmp123"
For Each ws In ThisWorkbook.Worksheets
ws.Copy After:=wb.Sheets(wb.Sheets.Count)
Next ws
'Remove Sheet1
wb.Sheets("Tmp123").Delete
For Each ws In wb.Worksheets
ws.Range(ws.Cells(1, 1), ws.Cells.SpecialCells(xlLastCell)).Copy
ws.Select
ws.Cells(1, 1).Select
ws.Pictures.Paste
ws.Range(ws.Cells(1, 1), ws.Cells.SpecialCells(xlLastCell)).Clear
Next ws
Set fDialog = Application.FileDialog(msoFileDialogSaveAs)
fDialog.Title = "Save Static Workbook"
fDialog.InitialFileName = ThisWorkbook.Path
If fDialog.Show = -1 Then
wb.SaveAs fDialog.SelectedItems(1)
End If
wb.Close SaveChanges:=False
Application.DisplayAlerts = True
End Sub
My problem is, that i have no idea, where i have to add this extra code. I have tried several options, for example to add it in the for loop, but this fails often in runtime errors.
Maybe someone of you can help me.
Thanks
When i use this code i get save as window and save workbook as i whish, but i also get one more workbook with active sheet from original, need help to get just one and if it is possible to close it after saving.
Code
Sub WorksheetSaveToNewWorkbook()
Dim loc As Variant
Dim Rng As Range
Dim newName As String
Dim newWkb As Workbook
Dim newWks As Worksheet
Dim Wks As Worksheet
Dim Shp As Shape
Application.DisplayAlerts = False
Set Wks = ThisWorkbook.ActiveSheet
Set Rng = Wks.Range("Q3:S170")
Data = Range("Q3:S170")
Wks.Copy
Set newWkb = Workbooks.Add
Set newWks = newWkb.ActiveSheet
With newWks
.Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
newName = " inklinometrija" & ".xlsx"
For Each Shp In .Shapes
Shp.OnAction = ""
Next Shp
loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:=newName)
If loc <> False Then
ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
Exit Sub
End If
Application.DisplayAlerts = True
End With
End Sub
Wks.Copy
Set newWkb = Workbooks.Add
Set newWks = newWkb.ActiveSheet
Wks.copy is in fact the code to create a new workbook with just that worksheet.
I have an issue runtime error 1004 with the below code, could anyone clarify for me what could be driving this?
Sub Excel1()
Dim rngLoopRange As Range
Dim wsSummary As Worksheet
Dim rngDealers As Worksheet
Set wsSummary = Sheets("PL")
For Each rngLoopRange In Worksheets("AUX").Range("A1:A38")
wsSummary.Range("C12").Value = rngLoopRange.Value
Application.Run "TM1REFRESH"
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\" & Range("C12").Value
ws.Copy before = wb.Worksheets(1)
Next rngLoopRange
Set wsSummary = Nothing
MsgBox "Complete!", vbInformation
End Sub
The above is now saving the file using the name I wanted, can you please advise now why it is giving me an
error '424'
on the sheet copying over. with the code line ws.Copy before = wb.Worksheets(1)
Sub Excel1()
Dim rngLoopRange As Range
Dim wsSummary As Worksheet
Dim rngDealers As Worksheet
Set wsSummary = Sheets("PL")
For Each rngLoopRange In Worksheets("AUX").Range("A1:A38")
wsSummary.Range("C12").Value = rngLoopRange.Value
Application.Run "TM1REFRESH"
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveWorkbook.SaveAs filename:=ThisWorkbook.Path & "\" & wsSummary.Range("C12").Value
ws.Copy before:=wb.Worksheets(1)
wb.Close savechanges:=True
Next rngLoopRange
Set wsSummary = Nothing
MsgBox "Complete!", vbInformation
End Sub