Runtime Error '9' Subscript out of range - excel

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!!!!

Related

VBA Word-to-Excel: Run-time error after activating excel workbook from VBA running on Word document

I have written a quite complex VBA script to run on a Word document to
transform it into an email body (together with a bunch of other documents),
combine it with other documents and save as pdf-attachment,
open email-distribution lists
create outlook items and put the distribution lists into a bcc field and body from earlier document
The script worked quite fine until it stopped for unclear to me reason. A "Run-time error '1001': Method 'Range' of object '_Global' failed." started to occur in the "Step 3 ...", specifically in the second line:
objLista.Worksheets(1).Activate
last_row = Range("A1").End(xlDown).Row
The script activates the worksheet just fine, but fails to do anything else with it. I tried to use explicit names of the workbook and worksheet in question, but it didn't help. The same lines in different yet similar script still work well. So I find it hard to find the source of the problem and correct it. I use MS Windows 10, and Office 365.
The whole script below:
Sub script()
' >>>>>>>>>>>>>>>>>>>>>>> Step 0. Declaration of variables and paths <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Dim Disclaimer_Path As String
Dim Email_Path As String
Dim objOutlook As Object
Dim objMail As Object
Dim ExcelApp As Excel.Application
Dim objLista As Workbook
Dim Today As String
Today = Format(Date, "yyyymmdd")
Disclaimer_Path = ...
Email_Path = "!_email.docx"
Distribution_list_Path = "!_List.xlsm"
Distribution_list_Path = "!_List_2.xlsm"
Pdf_Path = ...
Set objOutlook = CreateObject("Outlook.Application")
Set ExcelApp = New Excel.Application
' >>>>>>>>>>>>>>>>>>>>>>> Step 1. Creating e-mail body <<<<<<<<<<<<<<<<<<<<<<<<<<<
' First creating an email-body
Documents.Open FileName:=ActiveDocument.Path & "\1_News.docx"
Documents.Open FileName:=ActiveDocument.Path & "\2_Essay.docx"
Documents.Open FileName:=ActiveDocument.Path & "\3_Comment.docx"
Documents.Open FileName:=Disclaimer_Path
Documents.Open FileName:=Email_Path
Documents("1_News.docx").Activate
Selection.WholeStory
Selection.Copy
Documents("!_Email.docx").Activate
With Selection
.MoveDown
.MoveDown
.PasteAndFormat wdPasteDefault
End With
Documents("2_Essay.docx").Activate
Selection.WholeStory
Selection.Copy
Documents("!_Email.docx").Activate
Selection.PasteAndFormat wdPasteDefault
Documents("3_Comment.docx").Activate
Selection.WholeStory
Selection.Copy
Documents("!_Email.docx").Activate
With Selection
.PasteAndFormat wdPasteDefault
.WholeStory
End With
' Cleaning
Documents("2_Essay.docx").Close SaveChanges:=wdDoNotSaveChanges
Documents("3_Comment.docx").Close SaveChanges:=wdDoNotSaveChanges
Documents("Disclaimer.docx").Close SaveChanges:=wdDoNotSaveChanges
Stop
' >>>>>>>>>>>>>>>>>>>>>>>>>>>>> Step 2. Creation of pdf <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Documents("1_News.docx").Activate
Selection.WholeStory
Selection.Copy
ThisDocument.Activate
With Selection
'.Range.Text = vbNewLine
.MoveDown
.PasteAndFormat wdPasteDefault
.Range.Text = vbNewLine
.MoveDown
End With
ActiveDocument.ActiveWindow.View.Type = wdMasterView
With ActiveDocument.Subdocuments
.AddFromFile Name:=ActiveDocument.Path & "\2_Essay.docx"
.AddFromFile Name:=ActiveDocument.Path & "\3_Comment.docx"
.AddFromFile Name:=ActiveDocument.Path & "\4_Preview.docx"
.AddFromFile Name:=ActiveDocument.Path & "\5_Comment_2.docx"
.AddFromFile Name:=ActiveDocument.Path & "\8_Calendar.docx"
.AddFromFile Name:=Disclaimer_Path
End With
'Returns to standard view
ActiveDocument.ActiveWindow.View.Type = wdPrintView
Selection.HomeKey Unit:=wdStory
Stop
ActiveDocument.ExportAsFixedFormat Pdf_Path, wdExportFormatPDF
' >>>>>>>>>>>>>>>>>>>>>>>> Step 3. Creating Distribution lists <<<<<<<<<<<<<<<<<<<<<<<<<<<<
Set objLista = ExcelApp.Workbooks.Open(Distribution_list_Path)
ExcelApp.Visible = True
Dim lista_1 As String, lista_2 As String, lista_3 As String, lista_4 As String, lista_5 As String, lista_6 As String, lista_7 As String, lista_8 As String, lista_9 As String
lista_1 = ""
lista_2 = ""
lista_3 = ""
lista_4 = ""
lista_5 = ""
lista_6 = ""
lista_7 = ""
lista_8 = ""
lista_9 = ""
objLista.Worksheets(1).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_1 = lista_1 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(2).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_2 = lista_2 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(3).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_3 = lista_3 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(4).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_4 = lista_4 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(5).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_5 = lista_5 & "; " & Cells(i, 1).Value
Next i
objLista.Worksheets(6).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_6 = lista_6 & "; " & Cells(i, 1).Value
Next i
' Now differentr set of lists
Set objLista_2 = ExcelApp.Workbooks.Open(Distribution_list_Path_2)
objLista_2.Worksheets(1).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_7 = lista_7 & "; " & Cells(i, 1).Value
Next i
objLista_2.Worksheets(2).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_8 = lista_8 & "; " & Cells(i, 1).Value
Next i
objLista_2.Worksheets(3).Activate
last_row = Range("A1").End(xlDown).Row
For i = 1 To last_row
lista_9 = lista_9 & "; " & Cells(i, 1).Value
Next i
' >>>>>>>>>>>>>>>>>>>>>>>>>>>>> Step 4. Creates e-mails <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Documents("!_Email.docx").Activate
Selection.Copy
For Each Item In Array(lista_1, lista_2, lista_3, lista_4, lista_5, lista_6, lista_7, lista_8, lista_9)
With objOutlook.CreateItem(0)
oAccount = ""
.bcc = Item
.Subject = "Weekly"
.Attachments.add Pdf_Path
Set Editor = .GetInspector.WordEditor
Editor.Content.Paste
.Display
End With
Next Item
'Cleaning
Documents("1_News.docx").Close SaveChanges:=wdDoNotSaveChanges
Documents("!_email.docx").Close SaveChanges:=wdDoNotSaveChanges
Workbooks("!_List.xlsm").Worksheets("List_1").Activate
Range("A1").Select 'To żeby uniknąć jednego z błędów, który się wcześniej wywalał, gdy arkusz był zamykany z kursorem w innym miejscu niż "A1"
Workbooks("!_List.xlsm").Close SaveChanges:=wdDoNotSaveChanges
Workbooks("!_List_2.xlsm").Worksheets(1).Activate
Range("A1").Select 'To żeby uniknąć jednego z błędów, który się wcześniej wywalał, gdy arkusz był zamykany z kursorem w innym miejscu niż "A1"
Workbooks("!_List_2.xlsm").Close SaveChanges:=wdDoNotSaveChanges
End Sub

VBA code for seeing the size of each worksheet in a workbook

I came across code online for my question, but it doesn't seem to work properly (unless I'm missing something). I have a large excel file that I'm trying to cut down with a functioning code.
The code below calculates each sheet and posts the totals in a new worksheet, but the total output it gives me is 218MB. The file size shown in properties is 162MB and I have no idea where the extra 56MB is coming from
ub GetEachWorksheetSize()
Dim strTargetSheetName As String
Dim strTempWorkbook As String
Dim objTargetWorksheet As Worksheet
Dim objWorksheet As Worksheet
Dim objRange As Range
Dim i As Long
Dim nLastEmptyRow As Integer
strTargetSheetName = "Sheet Sizes"
strTempWorkbook = ThisWorkbook.Path & "\Temp Workbook.xls"
With ActiveWorkbook.Worksheets.Add(before:=Application.Worksheets(1))
.Name = strTargetSheetName
.Cells(1, 1) = "Sheet"
.Cells(1, 1).Font.Size = 14
.Cells(1, 1).Font.Bold = True
.Cells(1, 2) = "Size"
.Cells(1, 2).Font.Size = 14
.Cells(1, 2).Font.Bold = True
End With
Set objTargetWorksheet = Application.Worksheets(strTargetSheetName)
For Each objWorksheet In Application.ActiveWorkbook.Worksheets
If objWorksheet.Name <> strTargetSheetName Then
objWorksheet.Copy
Application.ActiveWorkbook.SaveAs strTempWorkbook
Application.ActiveWorkbook.Close SaveChanges:=False
nLastEmptyRow = objTargetWorksheet.Range("A" & objTargetWorksheet.Rows.Count).End(xlUp).Row + 1
With objTargetWorksheet
.Cells(nLastEmptyRow, 1) = objWorksheet.Name
.Cells(nLastEmptyRow, 2) = FileLen(strTempWorkbook)
End With
Kill strTempWorkbook
End If
Next
End Sub
I found another code below on another forum that is supposed to tackle the problem. The code runs, but doesn't output anything.
Sub SheetsSize()
Dim a(), Bytes As Double, i As Long, FileNameTmp As String
Dim Sh, Wb As Workbook
Set Wb = ActiveWorkbook
ReDim a(0 To Wb.Sheets.Count, 1 To 2)
' Turn off screen updating
Application.ScreenUpdating = False
On Error GoTo exit_
' Put names into a(,1) and sizes into a(,2)
With CreateObject("Scripting.FileSystemObject")
' Build the temporary file nane
FileNameTmp = .GetSpecialFolder(2) & "\" & Wb.Name & ".TMP"
' Save workbook
Wb.SaveCopyAs FileNameTmp
' Put workbook's name and size into a(0,)
a(0, 1) = Wb.Name
a(0, 2) = .GetFile(FileNameTmp).Size
' Put each sheet name and its size into a(i,)
For i = 1 To Wb.Sheets.Count
Wb.Sheets(i).Copy
ActiveWorkbook.SaveCopyAs FileNameTmp
a(i, 1) = Wb.Sheets(i).Name
a(i, 2) = .GetFile(FileNameTmp).Size
Bytes = Bytes + a(i, 2)
ActiveWorkbook.Close False
Next
Kill FileNameTmp
End With
' Show workbook's name & size
Debug.Print String(255, vbLf); a(0, 1), Format(a(0, 2), "# ### ### ##0") & " Bytes"
' Show each sheet name and its corrected size
For i = 1 To UBound(a)
Debug.Print String(255, vbLf); a(i, 1), Format(a(0, 2) * a(i, 2) / Bytes, "# ### ### ##0") & "
Bytes"
Next
exit_:
' Restore screen updating and show error reason if happened
Application.ScreenUpdating = True
' Show the reason of error if happened
If Err Then MsgBox Err.Description, vbCritical, "Error"
End Sub
Looking for some help on getting the exact total or if i'm not understanding something correctly

VBA to Update and Replace in Workbooks causes crashing

Please bear with me. My code is probably complete shit, so I appreciate all feedback! So what this does is, on my main workbook, there are a bunch of UNC hyperlinks in Row M, that link to files in a section drive.
What this code does:
Go down the list of hyperlinks in Column M, opens them up and executes the code inside of the "With WBSsource".
First, it searches for instances of the incorrect filepath (st) inside each of the cells formulas (NOT VALUES), and increments a counter using InStr (t), then after the worksheet has been searched, if the final count (c) is more than 0, meaning the search found at least one incorrect filepath, it will proceed to the next step.
It does a Cells.Replace on a worksheet (ws.) basis (at the FORMULA level)
Cells per worksheet are all done, it should save the workbook and close it before moving onto the next one.
Any links that could not be opened will appear in a final popup.
It is by Step 3 that it starts to run sluggish and crash.
I'm trying my best to get this automated and saving the workbooks. Then, once they're all updated, running this code again would be much faster cause it won't have to replace everything again.
Sub List_UpdateAndSave()
Dim lr As Long
Dim i As Integer
Dim WBSsource As Workbook
Dim FileNames As Variant
Dim msg As String
Dim ws As Worksheet
Dim r As Range, t As Long, c As Integer
' Update the individual credit models
With ThisWorkbook.ActiveSheet
lr = .Cells(.Rows.Count, "M").End(xlUp).Row
FileNames = .Range("M2:M" & lr).Value
End With
For i = LBound(FileNames, 1) To UBound(FileNames, 1)
On Error Resume Next
If FileNames(i, 1) Like "*.xls*" Then
Set WBSsource = Workbooks.Open(FileNames(i, 1), _
ReadOnly:=False, _
Password:="", _
UpdateLinks:=3)
If Err = 0 Then
With WBSsource
Application.DisplayAlerts = False
ActiveWorkbook.Final = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
st = "\\corp\Accounts\" 'Search Phrase
n = "\\corp\StackOverflow\Accounts\" 'New Phrase
c = 0
For Each ws In WBSsource.Worksheets
ws.Activate
t = 0
On Error Resume Next
For Each r In ws.Cells.SpecialCells(xlCellTypeFormulas)
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
Next r
Next ws
If c > 0 Then
'MsgBox ws.Name & Chr(10) & (c)
ws.Cells.Replace st, n
End If
.UpdateLink Name:=ActiveWorkbook.LinkSources, Type:=xlExcelLinks
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
.Save
.Close True
End With
Else
msg = msg & FileNames(i, 1) & Chr(10) & Chr(10)
On Error GoTo 0
End If
End If
Set WBSsource = Nothing
Next i
If Len(msg) > 0 Then
'MsgBox "The Following Files Could Not Be Opened" & _
' Chr(10) & msg, 48, "Error"
Set objShell = CreateObject("Wscript.Shell")
objShell.Popup "The Following Files Could Not Be Opened" & _
Chr(10) & Chr(10) & msg, 48, "Error"
End If
Application.DisplayAlerts = True
End Sub
It's not completely crap. I just learned that we could create an array with this.
FileNames = .Range("M2:M" & lr).Value
It may crash since there's no range limit on the 3rd step. Try getting the last row and column on each worksheet, then create a range based on that.
With ws
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For each r in .Range(.Cells(1,1), .Cells(intLastRow, intLastCol))
' Check formula if it contains specific string
t = InStr(1, r.Formula, st)
If t > 0 Then
c = c + 1
End If
' Replace formula with new string
r.Formula = Replace(r.Formula, st, n)
Next r
End With
Edit: Here's the full code. Let me know if this works for you.
Option Explicit
' Update the individual credit models
Sub List_UpdateAndSave()
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error GoTo ErrorHandler
' Declaration
Dim i As Long
Dim arrLinks As Variant
Dim strLinksErr As String
' Initialization
Dim strPathCur As String: strPathCur = "\\corp\Accounts\" ' search phrase
Dim strPathNew As String: strPathNew = "\\corp\StackOverflow\Accounts\" ' new phrase
With ThisWorkbook.ActiveSheet
' Get links from sheet
arrLinks = .Range("M2:M" & .Cells.SpecialCells(xlCellTypeLastCell).Row).Value
End With
For i = LBound(arrLinks, 1) To UBound(arrLinks, 1)
' Check for Excel links
If VBA.InStr(1, arrLinks(i, 1), ".xls", vbTextCompare) > 0 Then
FnExcelUpdateLinks arrLinks(i, 1), strPathCur, strPathNew
Else
' Add to list of links that could not be opened
strLinksErr = strLinksErr & arrLinks(i, 1) & Chr(10)
End If
Next i
ErrorHandler:
' Display any errors
If Err.Number <> 0 Then MsgBox Err.Description, vbCritical, "Error " & Err.Number
' Display any non-Excel links
If strLinksErr <> "" Then
MsgBox "The following files could not be opened:" & _
Chr(10) & strLinksErr, 48, "Error"
End If
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Function FnExcelUpdateLinks(ByVal strWbkPath As String, ByRef strPathCur As String, ByRef strPathNew As String)
Dim intLastRow As Long, intLastCol As Long
Dim wbkTmp As Workbook
Dim shtTmp As Worksheet
Dim rngCell As Range
' Open link as workbook
Set wbkTmp = Workbooks.Open(strWbkPath, ReadOnly:=False, Password:="", UpdateLinks:=3)
With wbkTmp
For Each shtTmp In .Worksheets
With shtTmp
' Get end cells
With .Cells.SpecialCells(xlCellTypeLastCell)
intLastRow = .Row
intLastCol = .Column
End With
For Each rngCell In .Range(.Cells(1, 1), .Cells(intLastRow, intLastCol))
If VBA.InStr(1, rngCell.Formula, strPathCur) > 0 Then
rngCell.Formula = Replace(rngCell.Formula, strPathCur, strPathNew)
End If
Next rngCell
End With
Next shtTmp
.UpdateLink Name:=.LinkSources, Type:=xlExcelLinks
.Save
.Close True
End With
End Function

Loop and add one to the range

I have this workbook with 2 sheets, the first sheet has a list of information and the second sheet is a form. I need to go through each line on the first sheet and put that information into the form, and save that sheet as a new workbook and be named from a certain cell. I basically have it all, I just need to put it in a loop and add one to the range every time it loops. Here is what I got, is there a easy way to make it loop and add one to the range. Thanks.
Sub Range_Copy()
Worksheets("Sheet1").Range("J2").Copy Worksheets("Sheet4").Range("K3:O3")
Worksheets("Sheet1").Range("K2").Copy Worksheets("Sheet4").Range("E3:H3")
Worksheets("Sheet1").Range("A2").Copy Worksheets("Sheet4").Range("A1:O1")
Worksheets("Sheet1").Range("B2").Copy Worksheets("Sheet4").Range("E29:F29")
Worksheets("Sheet1").Range("C2").Copy Worksheets("Sheet4").Range("G29:H29")
Worksheets("Sheet1").Range("D2").Copy Worksheets("Sheet4").Range("D7:O7")
Worksheets("Sheet1").Range("E2").Copy Worksheets("Sheet4").Range("L8:O8")
Worksheets("Sheet1").Range("F2").Copy Worksheets("Sheet4").Range("D8:G8")
Worksheets("Sheet1").Range("G2").Copy Worksheets("Sheet4").Range("D9:O9")
Worksheets("Sheet1").Range("H2").Copy Worksheets("Sheet4").Range("D6:O6")
Worksheets("Sheet1").Range("I2").Copy Worksheets("Sheet4").Range("A48:O48")
Application.ScreenUpdating = False
ActiveSheet.Select
ActiveSheet.Copy
ThisFile = Range("A1").Value
ActiveSheet.SaveAs Filename:="H:\Intern Work\Server List\Server Form List\" &
ThisFile & ".xlsx"
Application.ScreenUpdating = True
ActiveWorkbook.Close
End Sub
Pretty sure this is what you're looking for, however I'm not sure if you're going to hit any snags when trying to save 600 individual files -
Sub Range_Copy()
Dim i As Long, lastrow As Long
Dim sht As Worksheet, sht2 As Worksheet, newwb As Workbook
Set sht = ThisWorkbook.Worksheets("Sheet1")
Set sht2 = ThisWorkbook.Worksheets("Sheet4")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = 2 To lastrow
sht2.Range("A1:O1").Value = sht.Range("A" & i).Value
sht2.Range("E29:F29").Value = sht.Range("B" & i).Value
sht2.Range("G29:H29").Value = sht.Range("C" & i).Value
sht2.Range("D7:O7").Value = sht.Range("D" & i).Value
sht2.Range("L8:O8").Value = sht.Range("E" & i).Value
sht2.Range("D8:G8").Value = sht.Range("F" & i).Value
sht2.Range("D9:O9").Value = sht.Range("G" & i).Value
sht2.Range("D6:O6").Value = sht.Range("H" & i).Value
sht2.Range("A48:O48").Value = sht.Range("I" & i).Value
sht2.Range("K3:O3").Value = sht.Range("J" & i).Value
sht2.Range("E3:H3").Value = sht.Range("K" & i).Value
Set newwb = Workbooks.Add
sht2.Copy Before:=newwb.Sheets(1)
newwb.SaveAs Filename:="H:\Intern Work\Server List\Server Form List\" & sht2.Range("A1").Value & ".xlsx"
newwb.Close False
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

How to auto populate a single spreadsheet from multiple spreadsheets

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

Resources