I'm really new to VBA coding. So my work requires a worksheet or form to be printed out for every production received. The current worksheet works great in generating out the form with all the details required. However, we have to batch print as we received up to 100 production at a time and its very manual to print each one. We will change the "Job number" and print it out. So I was wondering if there is any ways we could print out all at once. Take note its only one sheet each for 100 items. A loop maybe?
I will be really grateful if you have any solution to this.
Thank you
enter code here
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("STEP 1. JTW")
Set step2 = ThisWorkbook.Sheets("STEP 2. Repackaging Worksheet")
Dim n As Long, first As Long, Endd As Long
Dim lastrow As Long
Dim curvis As Long
n = Application.Match(VBA.CLng(Me.ComboBox2.Value), sh.Range("a:a"),0)
sh.Unprotect "udp"
step2.Unprotect "repackagingworksheet"
If Me.TextBox8.Value = "" Then
MsgBox "Please enter name!", vbCritical
Exit Sub
End If
Endd = Me.ComboBox3.Value
first = Me.ComboBox2.Value
sh.Range("L" & n).Value = Me.TextBox8.Value
sh.Range("M" & n).Value = Format(Now, "dd mmm yyyy hh:mm:ss")
For first = Me.ComboBox2.Value To Endd
step2.Range("f2").Value = Me.ComboBox2.Value
step2.Range("f2").Value = first
sh.Range("L" & first).Value = Me.TextBox8.Value
sh.Range("M" & first).Value = Format(Now, "dd mmm yyyy
hh:mm:ss")
With step2
.curvis = .Visible
.Visible = xlSheetVisible
.PageSetup.PrintArea = "$A$1:$D$47"
.PrintOut copies:=1, IgnorePrintAreas:=False
.Visible = curvis
End With
Next first
ActiveWorkbook.Save
Me.Hide
sh.Protect "udp", AllowFiltering:=True
step2.Protect "repackagingworksheet"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Related
I can't figure out why it is not deleting the row if the user selects no.
I even tried telling to delete a certain line in the ws but it still did not delete that row
Adding the data if it is not there works.
If it is already there the message box does pop up.
The only function that is not working is the delete.
Sub Submit_Data()
Application.ScreenUpdating = False
Dim App As New Excel.Application
Dim wBook As Excel.Workbook
Dim ws As Worksheet, id, v, m
Dim FileName As String
Dim CurrentJob As Long
Dim CurrentRow As Variant '<--- NOTE
Dim CurrentCell As Variant
Dim iRow As Long
FileName = ThisWorkbook.Path & "\database.xlsm"
'Check File Exist or Not
'If Dir(FileName) = "" Then
'MsgBox "Database File is missing. Unable to proceed.", vbOKOnly vbCritical, "Error"
'Exit Sub
'End If
Set wBook = App.Workbooks.Open(FileName)
App.Visible = False
If wBook.ReadOnly = True Then
TryWriteMode book:=wBook _
, numberOfTries:=4 _
, secondsWaitAfterFailedTry:=10
' MsgBox "test", vbInformation
End If
If wBook.ReadOnly Then
MsgBox "Database is in use. Please try again later.", vbOKOnly + vbInformation, "Read-only book"
Exit Sub
End If
'Transfer the Data
id = TextBox2.Value
With wBook.Sheets("database")
Set ws = wBook.Sheets("database")
' m = Application.Match(id, ws.[B:B], 0) 'try to match an existing row
m = Application.Match(id, 5, 0)
CurrentJob = TextBox2.Value
CurrentRow = Application.Match(CurrentJob, ws.Range("B:B"), 0)
CurrentCell = ws.Cells(CurrentRow, 1)
If IsError(CurrentRow) Then
iRow = .Range("A" & Application.Rows.Count).End(xlUp).Row + 1
.Range("A" & iRow).Value = TextBox1.Value 'Cell
.Range("B" & iRow).Value = TextBox2.Value 'workorder number
.Range("C" & iRow).Value = TextBox3.Value 'product number
.Range("D" & iRow).Value = TextBox4.Value 'Work order quanity
Else
MsgBox "JOB ALREADY ASSIGNED TO " & CurrentCell & vbNewLine & "DO YOU WANT TO KEEP IT THIER ", vbYesNo
If Result = vbNo Then
ws.Rows(CurrentRow).EntireRow.Delete
End If
End If
End With
wBook.Close Savechanges:=True
App.Quit
Set App = Nothing
'Reset the form
Call resetForm
Application.ScreenUpdating = True
End Sub
I have below code which has to cut the data and copy into another sheet called data_base but its not happening its copying the data in username-password.xlsx and i am facing one more problem is once i try to close the userform Logout button should appear when i click on logout button its giving error at line "Worksheets("data1").Range("B1").Value = Date & " " & Time ' as subscript out of range.
Private Sub CommandButton1_Click()
Dim username As String
Dim password As String
username = TextBox1.Text
password = TextBox2.Text
Dim info
info = IsWorkBookOpen("D:\TMS_Project\username-password.xlsx")
If info = False Then
Workbooks.Open ("D:\TMS_Project\username-password.xlsx")
End If
Dim x As Integer
x = 2
Do While Cells(x, 1).Value <> ""
If Cells(x, 1).Value = username And Cells(x, 2).Value = password Then
MsgBox "Welcome!"
Worksheets("data1").Range("A1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
UserForm1.Hide
ActiveWorkbook.Close True
End
Else
x = x + 1
End If
Loop
MsgBox "Please check your username or password!"
ActiveWorkbook.Close True
TextBox1.Text = ""
TextBox2.Text = ""
TextBox1.SetFocus
End Sub
Private Sub CommandButton6_Click()
Worksheets("data1").Range("B1").Value = Date & " " & Time
Selection.NumberFormat = "m/d/yyyy h:mm AM/PM"
ThisWorkbook.Save
Worksheets("data1").Range("A1:B1").Select
Selection.Cut
Unload Me
getlogindata
ActiveWorkbook.Close True
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
End If
End Sub
Sub getlogindata()
Dim info
info = IsWorkBookOpen("D:\TMS_Project\Log_Details..xlsx")
' we open the workbook if it is closed
If info = False Then
Workbooks.Open ("D:\TMS_Project\Log_Details..xlsx")
End If
Worksheets("data_base").Activate
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("data_base").Range(Cells(erow, 1), Cells(erow, 2))
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.Quit
End Sub
any help is appreciated as i got stuck at this and could not able to progress with my login and logout system.
I don't think you have a sheet called "data1" in the currently active workbook. Try fully qualifying the reference as
Workbooks("Log_Details..xlsx").worksheets("data1").range("B1")= Date & " " & Time
or Activate the desired workbook first
I have a set of Excel spreadsheets to summarise. My sheets are numbered:
xxx-yy-zzzz; xxx-yy-zzz+1; etc.
I would like a reporting spreadsheet to retrieve information each time it is opened. I don't mind doing it with VBA or with formulae.
I've the macro below. I need to auto increment until it runs out of spreadsheets. All the files will be in the same folder, this file can be in any folder.
Sub Macro1()
'
' Macro1 Macro
' autopop
'
'
Range("C4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R4C5"
Range("D4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R5C3"
Range("E4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Order'!R27C9"
Range("F4").Select
ActiveCell.FormulaR1C1 = "='[413-05-001.xlsx]Cover'!R8C9"
End Sub
Siddharth's method above worked very well for when we were using very simple file names, but it got a lot harder when there were additions made to the filename... So i did some surfing and found a basis of a "list all files and put them in a worksheet" and using some of the code from Siddharth's answer above (thank you very much Mr. Siddharth) and the example i found online here http://alanmurray.blogspot.com/2013/08/excel-vba-list-all-excel-files-in-folder.html , i have finalised my code, and my little VBA app now does what i want - it opens a folder and goes through and pulls out particular cells and creates a summary report in seconds -> will save me hours of tedious work...
Code:
Sub ImportFileList()
Dim MyFolder As String 'Store the folder selected by the using
Dim FiletoList As String 'store the name of the file ready for listing
Dim NextRow As Long 'Store the row to write the filename to
On Error Resume Next
Application.ScreenUpdating = False
'Display the folder picker dialog box for user selection of directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\"
End With
'Dir finds the first Excel workbook in the folder
FiletoList = Dir(MyFolder & "*.xls")
Range("A1").Value = "Filename"
Range("B1").Value = "Purchase Order Number"
Range("C1").Value = "Vendor"
Range("D1").Value = "Date of PO"
Range("E1").Value = "Currency"
Range("F1").Value = "Subtotal"
Range("G1").Value = "VAT"
Range("H1").Value = "Total"
Range("A1:H1").Font.Bold = True
'Find the next empty row in the list
NextRow = Application.CountA(Range("A:A")) + 1
NextRow = NextRow + 1 ' skip a line
'Do whilst the dir function returns an Excel workbook
Do While FiletoList <> ""
Cells(NextRow, 1).Value = FiletoList 'Write the filename into the next available cell
Cells(NextRow, 2).Formula = "='[" & FiletoList & "]Cover'!R4C4" ' Cover is the excel sheet name
Cells(NextRow, 3).Formula = "='[" & FiletoList & "]Cover'!R6C3"
Cells(NextRow, 4).Formula = "='[" & FiletoList & "]Cover'!R4C7"
Cells(NextRow, 5).Formula = "='[" & FiletoList & "]Cover'!R21C4"
Cells(NextRow, 6).Formula = "='[" & FiletoList & "]Cover'!R19C5"
Cells(NextRow, 7).Formula = "='[" & FiletoList & "]Cover'!R20C5"
Cells(NextRow, 8).Formula = "='[" & FiletoList & "]Cover'!R21C5"
NextRow = NextRow + 1 'Move to next row
FiletoList = Dir 'Dir returns the next Excel workbook in the folder
Loop
Application.ScreenUpdating = True
End Sub
Is this what you are trying? (UNTESTED)
'~~> Change this to the directory which has .xlsx files
Const sDir = "C:\Temp\"
Sub Sample()
Dim ws As Worksheet
Dim i As Long, num As Long, Calcmode As Long
Dim FilesCount As Long, startNum As Long
On Error GoTo Whoa
Set ws = ThisWorkbook.Sheets("Sheet1")
With Application
.ScreenUpdating = False
Calcmode = .Calculation
.Calculation = xlCalculationManual
End With
'~~> Get the number of files in that directory
FilesCount = getFileCount(sDir)
startNum = 1
If FilesCount <> 0 Then
With ws
For i = 4 To (FilesCount + 3)
num = Format(startNum, "000")
.Range("C" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R4C5"
.Range("D" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R5C3"
.Range("E" & i).Formula = "='[413-05-" & num & ".xlsx]Order'!R27C9"
.Range("F" & i).Formula = "='[413-05-" & num & ".xlsx]Cover'!R8C9"
startNum = startNum + 1
Next i
End With
End If
LetsContinue:
With Application
.ScreenUpdating = True
.Calculation = Calcmode
End With
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Function getFileCount(s As String) As Long
Dim Path As String, Filename As String
Dim Count As Long
Path = s & "*.xlsx"
Filename = Dir(Path)
Do While Filename <> ""
Count = Count + 1
Filename = Dir()
Loop
getFileCount = Count
End Function
I am using excel VBA to create a new sheet then copy data from another sheet to this new sheet I created. Then I will format the new sheet by deleting some columns and text wrapping. It does the job alright However it is not efficient: The screen flickers so much despite using Application.DisplayAlerts = False, Application.EnableEvents = False.
Any help?
Sub ProcessPostingData()
Dim MyDateTime As String
Dim szToday As String
Dim szTime As String
Dim TD, TM As String
Dim AfterFilterFinalRow As Long
Dim lLastRow3nd As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Sheets("szTempNow").Delete
On Error GoTo 0
Sheets.Add().Name = "szTempNow"
Worksheets("DATA_PROCESSING").Select
lLastRow3nd = Cells(1, 6).EntireColumn.Find("*", SearchDirection:=xlPrevious).Row
'We sort,create sheet with DateTime stamp,copy data to new sheet and format
ActiveWorkbook.Worksheets("DATA_PROCESSING").Range(Cells(1, 1), Cells(lLastRow3nd, 10)).Sort _
Key1:=Range("A1"), Header:=xlYes
With Worksheets("DATA_PROCESSING")
AfterFilterFinalRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Sheets("DATA_PROCESSING").Range("A1:J1").Copy Destination:=Sheets("szTempNow").Range("A1")
Sheets("szTempNow").Range("A2:J" & AfterFilterFinalRow).Value = Sheets("DATA_PROCESSING").Range("A2:J" & AfterFilterFinalRow).Value
Sheets("DATA_PROCESSING").Range(Cells(2, 1), Cells(AfterFilterFinalRow, 10)).EntireRow.Delete
'Removing columns not needed and formating
Sheets("szTempNow").Select
'With Sheets("szTempNow")
.Columns("G:G").Delete Shift:=xlToLeft
.Columns("D:E").Delete Shift:=xlToLeft
End With
'With Range(Cells(1, 1), Cells(AfterFilterFinalRow, 10))
'.HorizontalAlignment = xlGeneral
'.VerticalAlignment = xlCenter
'.WrapText = True
'.ReadingOrder = xlContext
'End With
'Range("E2:E" & AfterFilterFinalRow).Columns("E:E").ColumnWidth = 70
'Rename Sheet with Todays date and Time
szTime = Format(Time, "h-mm AM/PM")
szToday = Format(Now(), "dd-mmm-yyyy")
TD = "D"
TM = "T"
MyDateTime = TD & szToday & TD & "_" & TM & szTime & TM
ActiveSheet.Name = MyDateTime
Range("K1").Value = ActiveSheet.Name
Range("K1").Font.Bold = True
With Range("K1")
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With
Application.EnableEvents = False
Application.DisplayAlerts = True
End Sub
You are looking for:
Application.ScreenUpdating = False
That's the one that helps stop screen flickering, and can also speed up processing. Application.DisplayAlerts suppresses dialogs along the lines of "This Workbook is Unsaved."
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!!!!