I have a macro to export the current page without any formulas or code. There are a few problems.
Sub ExportXLSX()
Application.EnableEvents = False
Dim MyPath As String
Dim MyFileName As String
MyFileName = Sheets("Order Summary").Range("B2").Value & "_" & Format(Date, "yyyymmdd")
If Not Right(MyFileName, 4) = ".xlsx" Then MyFileName = MyFileName & ".xlsx"
Sheets("Order Summary").Copy
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select where you want to save"
.AllowMultiSelect = False
.InitialFileName = "" 'Start folder path for the file picker.
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
With ActiveWorkbook
.ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value '<~~ converts contents of XLSX file to values only
.SaveAs filename:=MyPath & MyFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close False
End With
Application.EnableEvents = True
End Sub
Format(Date, "yyyymmdd") doesn't seem to work for the filename.
I would like to remove the drop down boxes I have in column A.
I would like to remove the shape boxes I use for my macros.
Basically want to strip the document to only dumb text so I can email it.
Thanks
You can remove validation by doing:
Activesheet.Cells.Validation.Delete
(though qualifying the sheet name would be ideal).
You can also loop through shapes within a worksheet by doing something like:
Dim shp as Shape
For each shp in ActiveSheet.Shapes
shp.delete
Next
These two steps should remove all shapes, and should remove all data validation.
Related
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 created a VBA code that loops through all excel workbooks in a given folder , opens then, refreshes the sheet, pauses for 10 seconds, closes and saves and moves on to the next. The issue I am facing is that it wont do it for the excel workbooks in the subfolder, Please can someone assist.
The code is as per below:
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
Application.Calculate
ActiveWorkbook.RefreshAll
Application.Wait (Now + TimeValue("0:00:10"))
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Its probably an old question indeed, but still, I enjoyed writing it somehow. And in my solution, you get some nice printing in the console. Here you go:
Option Explicit
Function GetFiles(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFiles = New Collection
strFile = Dir(Folder & "\*")
Do While strFile <> ""
GetFiles.Add strFile
strFile = Dir
Loop
End Function
Function GetFolders(ByVal Folder As String) As Collection
Dim strFile As String
Set GetFolders = New Collection
strFile = Dir(Folder & "\*", vbDirectory)
Do While strFile <> ""
If GetAttr(Folder & "\" & strFile) And vbDirectory Then GetFolders.Add strFile
strFile = Dir
Loop
End Function
Sub LoopThroughSubfoldersAsWell()
Dim colFoFi As Collection
Dim varEl01 As Variant
Dim varEl02 As Variant
Dim varEl03 As Variant
Dim strLine As String: strLine = "--------------------------"
Dim strAddress As String: strAddress = "C:\Users\UserName\Desktop\Testing01\"
Debug.Print strAddress
Set colFoFi = GetFiles(strAddress)
For Each varEl01 In colFoFi
Debug.Print varEl01
Next varEl01
Debug.Print strLine
Set colFoFi = GetFolders(strAddress)
For Each varEl01 In colFoFi
If Len(varEl01) > 2 Then 'to avoid some hidden stuff
Set varEl02 = GetFiles(strAddress & varEl01)
Debug.Print (strAddress & varEl01)
For Each varEl03 In varEl02
Debug.Print varEl03
Next varEl03
Debug.Print strLine
End If
Next varEl01
End Sub
I made a code to help me save some files quickly in a folder optimasing an online exemple. When i save the file in xls format, everything looks normal, but when i do it in xlsx and try to open the saved file, an erro appears telling me that the format is corrupted.
All files where in xls in beginning
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'security biass
If Worksheets("atualizador").Range("H6") <> "x" Or Worksheets("atualizador").Range("H7") <> "x" Then
Exit Sub
End If
'start folder
myPath = "C:\Users\anna.costa\Downloads\Dados\"
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'copy Worksheet's and rename
If Right(myFile, 5) <> ")" Then
Select Case Left(myFile, 1)
Case "V"
wb.SaveAs ("C:\Users\anna.costa\Desktop\Dados_FIPE\ANBIMA\VNA\" & setnameVNA(myFile) & ".xlsx")
wb.Close SaveChanges:=False
Case "m"
wb.SaveCopyAs ("C:\Users\anna.costa\Desktop\Dados_FIPE\ANBIMA\TÍTULO_PÚBLICO\" & setnameTP(myFile) & ".xls")
wb.Close SaveChanges:=False
Case "C"
wb.SaveCopyAs ("C:\Users\anna.costa\Desktop\Dados_FIPE\ANBIMA\ETTJ\" & setnameETTJ(myFile) & ".xlsx")
wb.Close SaveChanges:=False
End Select
End If
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
You are trying to open an xls file and save it as an xlsx file, without any conversion. To properly convert the file to xlsx you need to include the right FileFormat:
wb.SaveAs "C:\Users\anna.costa\Desktop\Dados_FIPE\ANBIMA\ETTJ\" & setnameETTJ(myFile) & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
wb.Close SaveChanges:=False
I faced a similar situation, what I did was this
Set WBDesiredToConvert = ThisWorkbook
WBDesiredToConvert.SaveAs ThisWorkbook.Path & "\" & "MacroEnabled", 52
I've created a excel spreadsheet template for our customers to populate and send back to us. I want to manually select their populated data and save it as a .csv to import into another piece of software. I, first, attempted this by recording a macro. This didn't work because different customers send different numbers of records.
I've tried snippets of code from online research and came up with this.
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
Function SaveAs(initialFilename As String)
On Error GoTo EndNow
SaveAs = False
With Application.FileDialog(msoFileDialogSaveAs)
.AllowMultiSelect = False
.ButtonName = "&Save As"
.initialFilename = initialFilename
.Title = "File Save As"
'.Execute
.Show
SaveAs = .SelectedItems(1)
End With
EndNow:
End Function
Sub Select_To_CSV()
Dim rng As Range
Dim myrangearea()
Range(ActiveCell, ActiveCell.End(xlDown).End(xlToRight)).Select
Dim myPath As String, v
myPath = "p:\" & _
Format(Date, "yyyymmdd") & ".csv"
'myPath = "x:\" & Format(Date, "yyyymmdd") & ".csv"
v = SaveAs(myPath)
If v <> False Then ThisWorkbook.SaveAs v
End Sub
This worked really well except when I went back to look at the .csv in the folder it was the same worksheet not the selected columns.
Ultimately what I am looking to do is,
Manually select the columns I want
Run a macro that converts the selected columns to a .csv
Have the Save As Dialog Box appear
Navigate to the certain folder I want.
Here you go:
Sub MacroMan()
ChDrive "P:" '// <~~ change current drive to P:\
Dim copyRng As Excel.Range
Dim ThisWB As Excel.Workbook
Dim OtherWB As Excel.Workbook
Dim sName As String
'// set reference to the 'Master' workbook
Set ThisWB = ActiveWorkbook
'// assign selected range to 'copyRng'
Set copyRng = Application.InputBox(Prompt:="Select range to convert to CSV", Type:=8)
'// If the user selected a range, then proceed with rest of code:
If Not copyRng Is Nothing Then
'// Create a new workbook with 1 sheet.
Set OtherWB = Workbooks.Add(1)
'// Get A1, then expand this 'selection' to the same size as copyRng.
'// Then assign the value of copyRng to this area (similar to copy/paste)
OtherWB.Sheets(1).Range("A1").Resize(copyRng.Rows.Count, copyRng.Columns.Count).Value = copyRng.Value
'// Get save name for CSV file.
sName = Application.GetSaveAsFilename(FileFilter:="CSV files (*.csv), *.csv")
'// If the user entered a save name then proceed:
If Not LCase(sName) = "false" Then
'// Turn off alerts
Application.DisplayAlerts = False
'// Save the 'copy' workbook as a CSV file
OtherWB.SaveAs sName, xlCSV
'// Close the 'copy' workbook
OtherWB.Close
'// Turn alerts back on
Application.DisplayAlerts = True
End If
'// Make the 'Master' workbook the active workbook again
ThisWB.Activate
MsgBox "Conversion complete", vbInformation
End If
End Sub
This will allow you to manually select a range (including entire columns). It will then transfer said range onto a new sheet, save that sheet as a CSV, using the Save As dialog, and then close it afterwards.
I am using a code to loop through all files in a user specified folder and perform a task.
The codes begins executing and then unexpectedly aborts. The first attempt aborted after about 40 files. The second attempt went as far as 177 files. Upon aborting the results to that point are appearing and are accurate.
Does anyone have any idea as to why it may be aborting and/or a different solution. the destination folder has about 7000 files needing data extracted. See existing code below.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Folder As String
Dim MacroFile As String
Dim RowCTR As Integer
MacroFile = "Transportation Contact List.xlsm"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
RowCTR = 2
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Windows("\\ATLP3FILE5\shared\AITransport\AITFILES_mig-103009\AITUW\LDM\CIF").Activate
'CUT AND PASTE SECTION
Workbooks(myFile).Activate
Worksheets("CIF").Range("F5").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("A" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("h10").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("B" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("h12").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("C" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("D13").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("D" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("s64").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("E" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("Y5").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("F" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("X10").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("G" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("AB11").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("H" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
Worksheets("CIF").Range("W9").Copy
Workbooks(MacroFile).Worksheets("Sheet1").Range("I" & RowCTR).PasteSpecial (xlPasteValues)
Workbooks(myFile).Activate
'Save and Close Workbook
wb.Close SaveChanges:=False
'Get next file name
myFile = Dir
RowCTR = RowCTR + 1
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I've taken your code and tightened it up by removing all of the workbook.activate commands. Likewise, I've used direct value transfer in place of the clipboard's copy & paste special, values.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
Dim wb As Workbook, wsMFS1 As Worksheet
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim Folder As String
Dim MacroFile As String
Dim RowCTR As Integer
MacroFile = "Transportation Contact List.xlsm"
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
RowCTR = 2
Set wbMF = Workbooks(MacroFile).Worksheets("Sheet1")
'Loop through each Excel file in folder
Do While CBool(Len(myFile))
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
With wb.Worksheets("CIF")
'Windows("\\ATLP3FILE5\shared\AITransport\AITFILES_mig-103009\AITUW\LDM\CIF").Activate
'CUT AND PASTE SECTION
wsMFS1.Range("A" & RowCTR) = .Range("F5").Value
wsMFS1.Range("B" & RowCTR) = .Range("H10").Value
wsMFS1.Range("C" & RowCTR) = .Range("H12").Value
wsMFS1.Range("D" & RowCTR) = .Range("D13").Value
wsMFS1.Range("E" & RowCTR) = .Range("S64").Value
wsMFS1.Range("F" & RowCTR) = .Range("Y5").Value
wsMFS1.Range("G" & RowCTR) = .Range("X10").Value
wsMFS1.Range("H" & RowCTR) = .Range("AB11").Value
wsMFS1.Range("I" & RowCTR) = .Range("W9").Value
End With
'Save and Close Workbook
wb.Close SaveChanges:=False
Set wb = Nothing
'Get next file name
myFile = Dir
RowCTR = RowCTR + 1
Loop
Set wbMF = Nothing
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I don't know if that will save enough resource to finish off your long task but it should make some improvements.