When I add Application.DisplayAlerts = false and Application.DisplayAlerts = True either side of sheets("Sheet2").Delete I get the 440 error.
Not sure what the issue is but it runs no problem without the application.displayalerts.
I have been googling for ages I have tried a couple things mentioned on other questions posted on here. I feel like maybe i need another line of code or something.
Code that isnt working:
Private Sub CommandButton1_Click()
Dim numberCopies As Long
Dim currentRow As Long
Dim j As Long
Dim sht As Worksheet
Set sht = Sheets("sheet3")
currentRow = 2
Do While Not IsEmpty(sht.Cells(currentRow, 1))
numberCopies = sht.Cells(currentRow, 1)
For j = 2 To numberCopies
sht.Rows(currentRow).Copy
sht.Rows(currentRow).Insert Shift:=xlDown
currentRow = currentRow + 1
Next j
currentRow = currentRow + 1
Loop
Application.CutCopyMode = False
sht.Columns(1).Delete
Dim Path As String
Dim Filename1 As String
Dim Filename2 As String
Path = ThisWorkbook.Path & "\"
Filename1 = Range("B1")
Filename2 = Range("D1")
Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
ActiveWorkbook.SaveAs Filename:=Path & Filename1 & "-" & Filename2 & ".csv", FileFormat:=xlCSV
MsgBox "This usage file as been saved in the same folder as the Usage Upload Creator, it is saved as " & ActiveWorkbook.Name & " This workbook will now close and you can upload your usage file on CPQ. Thank You."
ActiveWorkbook.Close False
End Sub
I just dont want the "are you sure you want to delete the sheet" alert popping up.
Worked out in the comments what the problem was, The problem is that you cannot have the ActiveX button on the sheet that you're trying to delete. You can supress the error and alerts by using this:
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Sheet2").Delete
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
On Error GoTo 0
Related
novice here who usually finds his way with trial & error but coming up stumped here.
I have a loop that goes through files in a folder and copies data from each file and in to a master.
As each files are working documents there is a chance another user could have one of these files open so I am trying to negate past a file when it is read-only.
I've tried a filecounter not sure I'm grasping it!
Sub Pull_Decisions()
Dim x As Workbook, y As Workbook
Dim folderPath As String, path As String
Dim StartTime As Double, SecondsElapsed As Double
Dim fileCounter As Integer
'Remember time when macro starts
StartTime = Timer
'Removes filters to allow all data to be shown and reduce risk of overwriting data
On Error Resume Next
ActiveSheet.ShowAllData
'message to prompt user to check filter
filterCheck = MsgBox("Please check all filters are cleared before proceeding. Do you want to proceed?", vbYesNo)
Application.Visible = False 'Hides Excel whilst Macro Running
'Application.Visible = True
If filterCheck = vbYes Then
Application.ScreenUpdating = False
'Set this workbook as x workbooks
Set x = ThisWorkbook
x.Worksheets(1).range("K5").Value = Format(Now(), "dd/mm/yyyy hh:mm:ss") 'Update refresh time
If x.ReadOnly Then
Application.ScreenUpdating = True
y.Close 'close master workbook
MsgBox "Decision Submissions spreadsheet is in read only mode and cannot refresh. Please reopen in write mode to refresh table."
Application.Visible = True
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
End If
'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 = "PATH TO REQUIRED 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 = "*.xlsm*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
Set y = ThisWorkbook
Set ws2 = y.Sheets("Allsubmissions")
'Loop through each Excel file in folder
Do While myFile <> "" Or fileCounter = 50
fileCounter = fileCounter + 1
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
If wb.ReadOnly Then 'If someone is in the workbook, the file will open as read only.
Application.ScreenUpdating = True
wb.Close
'MsgBox " Workbook is currently in use, please try again shortly"
Else
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook
With wb.Sheets("Decisions")
lRow = .range("A" & Rows.Count).End(xlUp).Row
.range("A2:I2" & lRow).Copy ws2.range("A" & Rows.Count).End(xlUp)(2)
.range("A2:I2" & lRow).Delete
End With
wb.Close SaveChanges:=True
'Get next file name
myFile = Dir
End If
Loop
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Else
'If person wants to abort the refresh to clear the filter (shouldn't be required due to above code)
MsgBox "refresh aborted"
Application.Visible = True
'Determine how many seconds code took to run
SecondsElapsed = Round(Timer - StartTime, 2)
'Notify user in seconds
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
Exit Sub
End If
Application.Visible = True 'Makes excel visible again
'Determine how many seconds code took to run and notifies user
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
y.Save
End Sub
Ideally, i'd also like the folder to be pre-defined and not use "FldrPicker", but when i try this the code runs but nothing copies.
Sorry for the long post and would appreciate any help!
Option Explicit
Sub Pull_Decisions()
Const FOLDER = "C:\temp\so\70786709\"
Const EXT = "*.xlsm*"
Const LIMIT = 50 ' max files
Dim wbMaster As Workbook, wb As Workbook
Dim wsAll As Worksheet
Dim filecount As Long, lastrow As Long, total As Long
Dim myfile As String, ro As String, msg As String
Dim t0 As Single: t0 = Timer
Set wbMaster = ThisWorkbook
If wbMaster.ReadOnly Then
MsgBox "This workbook is in read only mode and cannot refresh. " & vbLf & _
"Please reopen in write mode to refresh table.", vbCritical, "Read Only"
wbMaster.Close
Exit Sub
End If
' prepare sheet
Set wsAll = wbMaster.Sheets("Allsubmissions")
wsAll.AutoFilterMode = False ' remove autofilter
wsAll.Range("K5").Value = Format(Now(), "dd/mm/yyyy hh:mm:ss")
' scan files in folder
myfile = Dir(FOLDER & EXT)
Application.ScreenUpdating = False
Do While myfile <> ""
filecount = filecount + 1
If filecount > LIMIT Then
MsgBox "File count > " & LIMIT, vbCritical
Exit Sub
End If
Set wb = Workbooks.Open(Filename:=FOLDER & myfile)
'If someone is in the workbook, the file will open as read only.
If wb.ReadOnly Then
ro = ro & vbLf & myfile ' store for later
wb.Close
Else
'Copy data on "SearchCaseResults" sheet to "Disputes" Sheet in other workbook ???
With wb.Sheets("Decisions")
lastrow = .Range("A" & .Rows.count).End(xlUp).Row
If lastrow > 1 Then
total = total + lastrow - 1
.Range("A2:I" & lastrow).Copy wsAll.Range("A" & Rows.count).End(xlUp).Offset(1)
.Range("A2:I" & lastrow).Delete
wb.Close SaveChanges:=True
Else
wb.Close SaveChanges:=False
End If
End With
End If
'Get next file name
myfile = Dir
Loop
Application.ScreenUpdating = True
' result
msg = total & " lines from " & filecount & " files." & vbLf
If Len(ro) > 0 Then
MsgBox msg & "These files were readonly; " & ro & vbLf & "Try again later.", vbExclamation, "Total = " & total
Else
MsgBox msg, vbInformation, Format(Timer - t0, "0.0 secs")
End If
End Sub
I'm building an automated request form and am running into a headache that only triggers for other users. 3 others receive a run-time error and I cannot figure out what is going on as I've used basically this same script in other books without ever having an issue reported.
Sub tracker_upload()
ActiveWindow.ScrollRow = 1
Run "processing" 'basic UF to display status
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Run "archive" 'saves completed form to a SP folder
With WaitForm
.lbStatus.Caption = "...archiving form to shared drive"
.Repaint
End With
Application.Wait (Now + TimeValue("00:00:02"))
With Form
If .Priority_Critical_YN = True Then
p = "Critical"
ElseIf .Priority_Must_Have_YN = True Then
p = "High"
ElseIf .Priority_Need_YN = True Then
p = "Medium"
ElseIf .Priority_Nice_YN = True Then
p = "Low"
End If
.Shapes("upload").Visible = False
End With
With Range("tbData")
uID = .Cells(1).Value
.Cells(2) = "New"
.Cells(3) = p
.Cells(9) = Environ$("UserName")
.Cells(10) = Date
.Hyperlinks.Add .Cells(1), ThisWorkbook.FullName, TextToDisplay:=uID
End With
With WaitForm
.lbStatus.Caption = "...updating tracker information"
.Repaint
End With
Dim wb1 As Workbook, wb2 As Workbook
On Error Resume Next
Set wb1 = ActiveWorkbook
Set wb2 = Workbooks("Requests Tracker")
'detect if workbook is already open and open if not
If wb2 Is Nothing Then
Application.Workbooks.Open ("My Shared Drive Location\Requests Tracker.xlsx"), ignorereadonlyrecommended = True
Set wb2 = Workbooks("Requests Tracker")
End If
On Error GoTo 0
wb1.Sheets("data").Range("tbData").Copy
With wb2
.Activate
With .Sheets("Requests")
If .Range("tbTracker").Cells(1) = "" Then
lastrow = .Range("A" & Rows.Count).End(xlUp).Row
Else: lastrow = .Range("A" & Rows.Count).End(xlUp).Row + 1
End If
.Range("A" & lastrow).PasteSpecial xlPasteAllUsingSourceTheme
.Columns.AutoFit
End With
.Save
.Close True
End With
Set wb2 = Nothing
On Error GoTo 0
With Application
.CutCopyMode = False
.ScreenUpdating = True
.DisplayAlerts = True
.Wait (Now + TimeValue("00:00:02"))
End With
Unload WaitForm
wb1.Save
mb = MsgBox("This request has been successfully recorded on the Tracker" & vbCrLf _
& vbCrLf _
& "The form will now close, would you like to open the tracker now?", vbYesNo + vbInformation, "completed")
If mb = vbYes Then
Application.Workbooks.Open ("My Shared Drive Location\Requests Tracker.xlsx"), ignorereadonlyrecommended = True
End If
If Application.Windows.Count = 1 Then
wb1.Saved = True
Application.Quit
Else: wb1.Close False
End If
End Sub
initially it was getting hung up on the .Sheets("Requests") line, then the line below it. It was the decimal in front of each, which I found really bizarre as I've never come across this before. Sure enough, after leaving the .Save and .Close True with decimals, it triggered another error on the next function preceded by a decimal as shown below.
UPDATE: I parsed out the bit of code where I set wb1 and wb2 as I identified it was wb2 that was giving the user an error. I did some testing with several other users who had no issue setting & identifying wb2 as Workbooks("Requests Tracker"). I finally got the sub to pass by adding the file extension to the end of the Workbook name. Why would this be required for this user only?
I had to specify set wb2 = "Requests Tracker.xlsx" in order for the user to not hit a run-time error. I do not know why .xlsx had to be added for this one user and no one else in the entire department...but that resolved the headache.
I'm searching for a code to run the same macro on 200+ files in the same folder directory until the last file is complete.
The macro I have currently does this once I click a button
Refresh .CSV data connection (File Selection window pops up in
the directory, I select the file)
Refreshes Pivot Table
Deletes Specific Tabs
Saves Copy As in another Directory
I want to eliminate me clicking the RUN button 200+ times, and selecting the .CSV file. Would anyone happen to know of a code that could do this?
Current MACRO is:
Sub Load_Brand3()
' Load_Brand3 Macro
Sheets("Data").Select
Range("DATATable[[#Headers],[Datetime]]").Select
Selection.ListObject.TableObject.Refresh
Sheets("Brand Summary").Select
Range("A13").Select
ActiveSheet.PivotTables("PivotTable1").PivotCache.Refresh
ActiveSheet.PivotTables("PivotTable1").PivotFields("Retailer.Name").ShowDetail _
= False
Sheets("Brand Summary").Select
Dim SavedCopy As Excel.Workbook
ActiveWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Workbooks.Open "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = ActiveWorkbook
With SavedCopy
ActiveWorkbook.Connections("BrandExport").Delete
Application.DisplayAlerts = False
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Sheets("Brand Summary").Select
Range("A1").Select
Application.DisplayAlerts = True
.Close True
End With
MsgBox ("Your File was saved.")
End Sub
This should be close. Just change MyPath to the correct directory and run ProcessFiles.
Sub ProcessFiles()
Const MyPath As String = "C:\Users\best buy\Data Files\*.csv"
Dim FileName As String
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
FileName = Dir(MyPath, vbDirectory)
Do While FileName <> ""
Load_BrandFile FileName
FileName = Dir()
Loop
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
Sub Load_BrandFile(FileName As String)
Dim SavedCopy As Workbook
Dim DATATable As ListObject
Dim PivotTable1 As PivotTable
ThisWorkbook.SaveCopyAs "C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm"
Set SavedCopy = Workbooks.Open("C:\Users\ME" & Format(Date, "mmddyyyy") & "-" & [A1] & ".xlsm")
With SavedCopy
Set DATATable = .Worksheets("Data").ListObjects("DATATable")
DATATable.Refresh
Set PivotTable1 = .Worksheets("Brand Summary").PivotTables("PivotTable1")
PivotTable1.PivotCache.Connection = FileName
PivotTable1.PivotFields("Retailer.Name").ShowDetail = False
.Connections("BrandExport").Delete
.Worksheets("Lookup").Delete
.Worksheets("Count").Delete
Application.Goto Reference:=.Worksheets("Brand Summary").Range("A1"), scroll:=True
.Close True
End With
End Sub
Hopefully this sorts it for you.
Sub CycleFolder()
Dim folderSelect As FileDialog
Set folderSelect = Application.FileDialog(msoFileDialogFolderPicker)
With folderSelect
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
strItem = .SelectedItems(1)
End With
Files = Dir(strItem & "\")
While Files <> ""
'RUN FUNCTION HERE
'Uncomment next line to test iteration
'Debug.Print Files
Files = Dir
Wend
End Sub
I have a macro that needs to open a few excel files and copy data from those files and paste them into the macro file in a sheet named "Consolidated".
The macro goes to a specified path, counts the number of files in the folder and then loops through to open a file, copy the contents and then save and close the file.
The macro runs perfectly on my system but not on the users systems.
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range". The line on which this error pops up is
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
At first i thought that the files might be opening slower than the code execution so i added wait time of 5 seconds before and after the above line...but to no avail.
The code is listed below
Sub grab_data()
Application.ScreenUpdating = False
Dim rng As Range
srow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
'Number of filled rows in column A of control Sheet
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
'Loop to find the number of excel files in the path in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
With Application.FileSearch
.LookIn = wkbpth
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
Application.Wait (Now + TimeValue("0:00:05"))
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Application.Wait (Now + TimeValue("0:00:05"))
filenm = ActiveWorkbook.Name
For sheet_count = 1 To Workbooks(filenm).Sheets.Count
If Workbooks(filenm).Sheets(sheet_count).Name <> "Rejected" Then
Workbooks(filenm).Sheets(sheet_count).Activate
ActiveSheet.Columns("a:at").Select
Selection.EntireColumn.Hidden = False
shtnm = Trim(ActiveSheet.Name)
lrow = ActiveSheet.Cells(65536, 11).End(xlUp).Row
If lrow = 1 Then lrow = 2
For blank_row_count = 2 To lrow
If ActiveSheet.Cells(blank_row_count, 39).Value = "" Then
srow = ActiveSheet.Cells(blank_row_count, 39).Row
Exit For
End If
Next blank_row_count
For uid = srow To lrow
ActiveSheet.Cells(uid, 40).Value = ActiveSheet.Name & uid
Next uid
ActiveSheet.Range("a" & srow & ":at" & lrow).Copy
ThisWorkbook.Sheets("Consolidated Data").Activate
alrow = ThisWorkbook.Sheets("Consolidated Data").Cells(65536, 11).End(xlUp).Row
ThisWorkbook.Sheets("Consolidated Data").Range("a" & alrow + 1).Activate
ActiveCell.PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1).Value = shtnm
ThisWorkbook.Sheets("Consolidated Data").Range("z" & alrow + 1 & ":z" & (alrow+lrow)).Select
Selection.FillDown
ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1).Value = wkbpth
ThisWorkbook.Sheets("Consolidated Data").Range("ap" & alrow + 1 & ":ap" & (alrow + lrow)).Select
Selection.FillDown
ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1).Value = filenm
ThisWorkbook.Sheets("Consolidated Data").Range("ao" & alrow + 1 & ":ao" & (alrow + lrow)).Select
Selection.FillDown
Workbooks(filenm).Sheets(sheet_count).Activate
ActiveSheet.Range("am" & srow & ":am" & lrow).Value = "Picked"
ActiveSheet.Columns("b:c").EntireColumn.Hidden = True
ActiveSheet.Columns("f:f").EntireColumn.Hidden = True
ActiveSheet.Columns("h:i").EntireColumn.Hidden = True
ActiveSheet.Columns("v:z").EntireColumn.Hidden = True
ActiveSheet.Columns("aa:ac").EntireColumn.Hidden = True
ActiveSheet.Columns("ae:ak").EntireColumn.Hidden = True
End If
Next sheet_count
Workbooks(filenm).Close True
Next file_count
End With
Next folder_count
Application.ScreenUpdating = True
End Sub
Thanks in advance for your help.
First off, make sure you have
Option Explicit
at the top of your code so you can make sure you don't mess any of your variables up. This way, everything is dimensioned at the beginning of your procedure. Also, use variables for your workbooks, it'll clean up the code and make it more understandable, also, use indenting.
This worked for me, I found that I need to make sure the file isn't already open (assuming you aren't using an add-in) so you don't want to open the workbook with the code in it when it is already open):
Sub grab_data()
Dim wb As Workbook, wbMacro As Workbook
Dim filecnt As Integer, file_count As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbMacro = ThisWorkbook
With Application.FileSearch
.LookIn = wbMacro.Path
.FileType = msoFileTypeExcelWorkbooks
.Execute
filecnt = .FoundFiles.Count
'Loop to count the number of sheets in each file
For file_count = 1 To filecnt
If wbMacro.FullName <> .FoundFiles(file_count) Then
Set wb = Workbooks.Open(Filename:=.FoundFiles(file_count))
Debug.Print wb.Name
wb.Close True
End If
Next file_count
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Hope that helps.
Try this (hope I didn't mess any of it up), basically, I'm checking to make sure the directory exists also, and I cleaned up the code quite a bit to make it more understandable (mainly for myself):
Sub grab_data()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim i As Long
Dim lRow As Long, lRowEnd As Long, lFolder As Long, lFilesTotal As Long, lFile As Long
Dim lUID As Long
Dim rng As Range
Dim sWkbPath As String
Dim wkb As Workbook, wkbTarget As Workbook
Dim wksConsolidated As Worksheet, wks As Worksheet
Dim v1 As Variant
Set wkb = ThisWorkbook
Set wksConsolidated = wkb.Sheets("Consolidated Data")
'Loop to find the number of excel files in the path in each row of the Control Sheet
For lFolder = 2 To wksConsolidated.Cells(65536, 1).End(xlUp).Row
sWkbPath = wksConsolidated.Cells(lFolder, 1).Value
'Check if file exists
If Not Dir(sWkbPath, vbDirectory) = vbNullString Then
With Application.FileSearch
.LookIn = sWkbPath
.FileType = msoFileTypeExcelWorkbooks
.Execute
lFilesTotal = .FoundFiles.Count
'Loop to count the number of sheets in each file
For lFile = 1 To lFilesTotal
If .FoundFiles(lFile) <> wkb.FullName Then
Set wkbTarget = Workbooks.Open(Filename:=.FoundFiles(lFile))
For Each wks In wkbTarget.Worksheets
If wks.Name <> "Rejected" Then
wks.Columns("a:at").EntireColumn.Hidden = False
lRowEnd = Application.Max(ActiveSheet.Cells(65536, 11).End(xlUp).Row, 2)
v1 = Application.Transpose(wks.Range(Cells(2, 39), Cells(lRowEnd, 39)))
For i = 1 To UBound(v1)
If Len(v1(i)) = 0 Then
lRow = i + 1
Exit For
End If
Next i
v1 = Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40)))
For lUID = 1 To UBound(v1)
v1(lUID) = wks.Name & lUID
Next lUID
Application.Transpose(wks.Range(Cells(lRow, 40), Cells(lRowEnd, 40))) = v1
wks.Range("a" & lRow & ":at" & lRowEnd).Copy
i = wksConsolidated.Cells(65536, 11).End(xlUp).Row
With wksConsolidated
.Range("A" & i).PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Range("z" & i + 1).Value = wks.Name
.Range("z" & i + 1 & ":z" & i + lRowEnd).FillDown
.Range("ap" & i + 1) = sWkbPath
.Range("ap" & i + 1 & ":ap" & i + lRowEnd).FillDown
.Range("ao" & i + 1) = wkbTarget.FullName
.Range("ao" & i + 1 & ":ao" & (i + lRowEnd)).FillDown
End With
With wks
.Range("am" & lRow & ":am" & lRowEnd) = "Picked"
.Columns("b:c").EntireColumn.Hidden = True
.Columns("f:f").EntireColumn.Hidden = True
.Columns("h:i").EntireColumn.Hidden = True
.Columns("v:z").EntireColumn.Hidden = True
.Columns("aa:ac").EntireColumn.Hidden = True
.Columns("ae:ak").EntireColumn.Hidden = True
End With
End If
Next wks
wkbTarget.Close True
End If
Next lFile
End With
End If
Next lFolder
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
End Sub
There may be two issues here
The macro runs perfectly on my system but not on the users systems
I presume you are running this in xl2003 as Application.FileSearch was deprecated in xl2007. So you are probably best advised to use a Dir approach instead to ensure your code works on all machines. Are you users all using xl2003?
You will get a "Object doesn't support this action" error in xl2007/10
The error i am receiving during the looping process is "Runtime Error '9' Subscript out of range
Is this error occuring on your machine, or on one/all of the user machines?
Ok guys,
I have finally been able to figure out the problem.
This error is occuring because some of the files in the raw data folder are corrupted and get locked automatically. So when the macro on opening the file gets an error and stops there.
I have now made a change to the macro. It would now first check if the files are all ok to be imported. If there is a corrupt file then it would list down their names and the user will be required to manually open it and then do a "save As" and save a new version of the corrupt file and then delete it.
Once this is done then the macro does the import of the data.
I am putting down the code below for testing the corrupt files.
Sub error_tracking()
Dim srow As Long
Dim rawfilepth As Integer
Dim folder_count As Integer
Dim lrow As Long
Dim wkbpth As String
Dim alrow As Long
Dim One_File_List As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ThisWorkbook.Sheets("Control Sheet").Activate
rawfilepth = Sheets("Control Sheet").Cells(65536, 1).End(xlUp).Row
Sheets("Control Sheet").Range("E2:E100").Clear
'Loop to find the number of excel files in the path
'in each row of the Control Sheet
For folder_count = 2 To rawfilepth
wkbpth = Sheets("Control Sheet").Cells(folder_count, 1).Value
One_File_List = Dir$(wkbpth & "\*.xls")
Do While One_File_List <> ""
On Error GoTo err_trap
Workbooks.Open wkbpth & "\" & One_File_List
err_trap:
If err.Number = "1004" Then
lrow = Sheets("Control Sheet").Cells(65536, 5).End(xlUp).Row
Sheets("Control Sheet").Cells(lrow + 1, 5).Value = One_File_List
Else
Workbooks(One_File_List).Close savechanges = "No"
End If
One_File_List = Dir$
Loop
Next folder_count
If Sheets("Control Sheet").Cells(2, 5).Value = "" Then
Call grab_data
Else
MsgBox "Please check control sheet for corrupt file names.", vbCritical, "Corrupt Files Notification"
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
This may not be one of the cleanest codes around, but it gets the job done. For those who have been troubled by this problem this is one of the ways to get around this problem. For those who havae a better way of doing this please respond with your codes.
Thanks to all for helping me out!!!!
How do I save each sheet in an Excel workbook to separate CSV files with a macro?
I have an excel with multiple sheets and I was looking for a macro that will save each sheet to a separate CSV (comma separated file). Excel will not allow you to save all sheets to different CSV files.
#AlexDuggleby: you don't need to copy the worksheets, you can save them directly. e.g.:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
Next
End Sub
Only potential problem is that that leaves your workbook saved as the last csv file. If you need to keep the original workbook you will need to SaveAs it.
Here is one that will give you a visual file chooser to pick the folder you want to save the files to and also lets you choose the CSV delimiter (I use pipes '|' because my fields contain commas and I don't want to deal with quotes):
' ---------------------- Directory Choosing Helper Functions -----------------------
' Excel and VBA do not provide any convenient directory chooser or file chooser
' dialogs, but these functions will provide a reference to a system DLL
' with the necessary capabilities
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
' the dialog title
Else
bInfo.lpszTitle = Msg ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1)
Else
GetFolderName = ""
End If
End Function
'---------------------- END Directory Chooser Helper Functions ----------------------
Public Sub DoTheExport()
Dim FName As Variant
Dim Sep As String
Dim wsSheet As Worksheet
Dim nFileNum As Integer
Dim csvPath As String
Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", _
"Export To Text File")
'csvPath = InputBox("Enter the full path to export CSV files to: ")
csvPath = GetFolderName("Choose the folder to export CSV files to:")
If csvPath = "" Then
MsgBox ("You didn't choose an export directory. Nothing will be exported.")
Exit Sub
End If
For Each wsSheet In Worksheets
wsSheet.Activate
nFileNum = FreeFile
Open csvPath & "\" & _
wsSheet.Name & ".csv" For Output As #nFileNum
ExportToTextFile CStr(nFileNum), Sep, False
Close nFileNum
Next wsSheet
End Sub
Public Sub ExportToTextFile(nFileNum As Integer, _
Sep As String, SelectionOnly As Boolean)
Dim WholeLine As String
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String
Application.ScreenUpdating = False
On Error GoTo EndMacro:
If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If
For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""
Else
CellValue = Cells(RowNdx, ColNdx).Value
End If
WholeLine = WholeLine & CellValue & Sep
Next ColNdx
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #nFileNum, WholeLine
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
End Sub
And here's my solution should work with Excel > 2000, but tested only on 2007:
Private Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' ask the user where to save
OutputPath = InputBox("Enter a directory to save to", "Save to directory", Path)
If OutputPath <> "" Then
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & "\" & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs FileName:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
(OT: I wonder if SO will replace some of my minor blogging)
Building on Graham's answer, the extra code saves the workbook back into it's original location in it's original format.
Public 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 = "C:\"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name, xlCSV
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
A small modification to answer from Alex is turning on and off of auto calculation.
Surprisingly the unmodified code was working fine with VLOOKUP but failed with OFFSET. Also turning auto calculation off speeds up the save drastically.
Public Sub SaveAllSheetsAsCSV()
On Error GoTo Heaven
' each sheet reference
Dim Sheet As Worksheet
' path to output to
Dim OutputPath As String
' name of each csv
Dim OutputFile As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
' Save the file in current director
OutputPath = ThisWorkbook.Path
If OutputPath <> "" Then
Application.Calculation = xlCalculationManual
' save for each sheet
For Each Sheet In Sheets
OutputFile = OutputPath & Application.PathSeparator & Sheet.Name & ".csv"
' make a copy to create a new book with this sheet
' otherwise you will always only get the first sheet
Sheet.Copy
' this copy will now become active
ActiveWorkbook.SaveAs Filename:=OutputFile, FileFormat:=xlCSV, CreateBackup:=False
ActiveWorkbook.Close
Next
Application.Calculation = xlCalculationAutomatic
End If
Finally:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
Heaven:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
"Source: " & Err.Source & " " & vbCrLf & _
"Number: " & Err.Number & " " & vbCrLf & _
"Description: " & Err.Description & " " & vbCrLf
GoTo Finally
End Sub
For Mac users like me, there are several gotchas:
You cannot save to any directory you want. Only few of them can receive your saved files. More info there
Here is a working script that you can copy paste in your excel for Mac:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "~/Library/Containers/com.microsoft.Excel/Data/"
For Each WS In ThisWorkbook.Worksheet
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Use Visual Basic to loop through worksheets and save .csv files.
Open up .xlsx file in Excel.
Press option+F11
Insert → Module
Insert this into the module code:
Public Sub SaveWorksheetsAsCsv()
Dim WS As Excel.Worksheet
Dim SaveToDirectory As String
SaveToDirectory = "./"
For Each WS In ThisWorkbook.Worksheets
WS.SaveAs SaveToDirectory & WS.Name & ".csv", xlCSV
Next
End Sub
Run the module.
(i.e. Click the play button at the top and then click "Run" on the dialog, if it pops up.)
Find your .csv files in ~/Library/Containers/com.microsoft.Excel/Data.
open ~/Library/Containers/com.microsoft.Excel/Data
Close .xlsx file.
Rinse and repeat for other .xlsx files.
Please look into Von Pookie's answer, all credits to him/her.
Sub asdf()
Dim ws As Worksheet, newWb As Workbook
Application.ScreenUpdating = False
For Each ws In Sheets(Array("EID Upload", "Wages with Locals Upload", "Wages without Local Upload"))
ws.Copy
Set newWb = ActiveWorkbook
With newWb
.SaveAs ws.Name, xlCSV
.Close (False)
End With
Next ws
Application.ScreenUpdating = True
End Sub