VBA code not stable - vba

It started on Monday this week, when I finished with my code,the codes purpose was to pull data from a specific sheet in a specific folder from all spreadsheets in that folder.
But just last night he started crashing excel spreadsheet every time i pushed the run button.
Any idea why?
Option Explicit
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Application.EnableEvents = False
SourceFolder = "C:\Users\Jarryd.Ward\Desktop\Test\"
FileType = "*.xlsx"
GrabSheet = "Summary"
FileList = ListFiles(SourceFolder & "/" & FileType)
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
For i = 1 To UBound(FileList)
Workbooks.Open (SourceFolder & "\" & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
ActiveWorkbook.Sheets(GrabSheet).Copy After:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
ActiveSheet.Name = ImpWorkBk
On Error Resume Next
ActiveSheet.Name = FileList(i) & " - " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
Workbooks(ActWorkBk).Activate
Next i
Application.ScreenUpdating = True
End Sub

Try opening and closing your files this way to see if it helps. It should minimize the calls to activate this or that. And closing out by variable instead of activesheet will insure that your code isn't trying to close the main workbook by accident.
Sub testOpen()
Dim manyWBs As Workbook
Dim myWB As Workbook
Set myWB = ThisWorkbook
For Each file In folder
Set manyWBs = Workbooks.Open("C:\temp\filename")
' do events.......
manyWBs.Worksheets("Sheet1").Range("A1:B13").Copy _
Destination:=myWB.Worksheets("Sheet1").Range("A1:b13")
manyWBs.Close
Set manyWBs = Nothing
Next file
Set myWB = Nothing
End Sub

Related

Pick folder routine going to Error handler - Excel VBA

Below is code that allows the user to choose a folder and opens files within the folder. It essentially does this:
On open, look for filepath saved in worksheet in workbook based on username. If doesn't exist, then prompt user to find folder, then save filepath in worksheet
From step 1, if filepath is found based on user, use that filepath
Error handler: From step 1, if filepath is found based on user, but that filepath is not in use anymore(i.e. user moved the folder to a different filepath), then have user find the folder again, then update existing record
What i'm experiencing is this:
When there's no entries in the sheet, then it will prompt user to
find the folder, but then proceed to the errorhandler and ask the
user to find the folder again
When there are entries in the sheet and the file path is working, the errorhandler is still opened and asks the user to find the
folder again
If I take out the errorhandler, everything is smooth. It's just that I want to cover the possibility of the user moving the folder , so I want the workbook to prompt the user to find where they moved the folder, and update the existing record in the workbook to the new path
What am I doing wrong here?
Private Sub Workbook_Open()
Dim wkb1 As Workbook
Dim sht1 As Worksheet
Dim wkb2 As Workbook
Dim sht2 As Worksheet
Dim vafiles As Variant
Dim filepath As String
Dim filepath2 As String
Dim filepath3 As String
Dim rw As Long
Dim ws As Worksheet
Dim lastrow As Long
Dim icounter As Long
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
Set ws = Worksheets("Paths")
rw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
Set wkb1 = ThisWorkbook
Set sht1 = wkb1.Sheets("Extract")
'======================================================
'Determine if Path was already saved before. If not, prompt user to choose folder
'======================================================
sal = Application.VLookup(Environ("username"), ws.Range("a:b"), 2, 0)
If IsError(sal) Then
MsgBox ("Please choose where your main folder is located. This will be stored so you won't need to look for it again.")
filepath = PICK_A_FOLDER()
ws.Cells(rw, 2) = PICK_A_FOLDER()
ws.Cells(rw, 1) = Environ("username")
Set wkb2 = Workbooks.Open(filepath & "\ Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic
Else
'======================================================
'If filepath exists, use that one
'======================================================
filepath2 = sal
Set wkb2 = Workbooks.Open(filepath2 & "Export.xlsx")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
End If
'======================================================
'If user has moved their folder, we can find it again and update their record
'======================================================
On Error GoTo Errorhandler
Errorhandler:
MsgBox ("Looks like you've moved your Folder. Please find it so your record will be updated")
filepath3 = PICK_A_FOLDER()
lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For icounter = 2 To lastrow
If Cells(icounter, 1) = Environ("username") Then
Cells(icounter, 2) = PICK_A_FOLDER()
End If
Next icounter
Set wkb2 = Workbooks.Open(filepath3 & "")
Set sht2 = wkb2.Sheets("Sheet1")
sht2.Cells.Copy Destination:=sht1.Range("a1")
Application.CutCopyMode = False
wkb2.Close True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
Worksheets("Instructions").Activate
Application.Calculation = xlAutomatic
End Sub
Actually solved this by taking out the errorhandler and inserting another if statement that captures an invalid directory:
if dir(sal & "Export.xlsx") = "" then
write error handler code
When a SubRoutine performs more that one task you should consider extracting the individual tasks into separate SubRoutines.
In this way:
You can debug each task independently of the other tasks
The logic is simplified into smaller units
The code is easier to read
You can reduce clutter by placing these SubRoutines into separate modules
Possible code reuse
Another unapparent benefit is that by simplifying the function of a SubRoutine it is much easier to remember the routines pattern and reuse the pattern when a similar situation arises.
Note: I often use If Len(...) then which is analogous to If Len(...) > 0 then. I do this to reduce clutter.
Standard Module
Function getSharedFolder() As String
Dim f As Range
With Worksheets("Paths")
Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
If Not f Is Nothing Then
'Dir([PathName], vbDirectory) returns empty if the [PathName] isn't a folder
If Len(Dir(f.Offset(0, 1).Value, vbDirectory)) Then
If Right(f.Offset(0, 1), 1) = "\" Then
getSharedFolder = f.Offset(0, 1)
Else
getSharedFolder = f.Offset(0, 1) & "\"
End If
End If
End If
End With
End Function
Function setSharedFolder() As Boolean
Dim f As Range
Dim PathName As String
PathName = PickSharedFolder
If Len(PathName) Then
setSharedFolder = True
With Worksheets("Paths")
Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Find(What:=Environ("username"), After:=.Range("A1"), LookAt:=xlWhole)
If f Is Nothing Then Set f = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Offset(1)
f.Value = Environ("username")
f.Offset(0, 1) = PathName
End With
End If
End Function
Function PickSharedFolder() As String
Application.FileDialog(msoFileDialogFolderPicker).ButtonName = "Select Folder"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Select Main Folder Location"
If .Show = -1 And .SelectedItems.Count = 1 Then
PickSharedFolder = .SelectedItems(1)
Else: Exit Function
End If
End With
End Function
Sub ToggleEvents(EnableEvents As Boolean, Optional DisplayAlerts = True)
With Application
.DisplayAlerts = DisplayAlerts
.EnableEvents = EnableEvents
.ScreenUpdating = EnableEvents
.Calculation = IIf(EnableEvents, xlCalculationAutomatic, xlCalculationManual)
End With
End Sub
Sub UpdateWorkBook(FilePath As String)
Dim WSSource As Worksheet
With Workbooks.Open(FilePath)
Set WSSource = .Sheets("Sheet1")
If WSSource Is Nothing Then
MsgBox "Sheet1 not found in " & FILENAME, vbCritical, "Update Cancelled"
Else
WSSource.Copy Destination:=ThisWorkbook.Sheets("Extract").Range("A1")
End If
.Close True
End With
End Sub
Workbook Module
Private Sub Workbook_Open()
Const FILENAME As String = "Export.xlsx"
Const PROMPT As String = "Press [Yes] to continue or [No] to cancel"
Dim FilePath As String, Title As String, SharedFolder As String
ToggleEvents False, False
Do
SharedFolder = getSharedFolder()
If Len(SharedFolder) = 0 Then
Title = "Folder not found"
Else
FilePath = SharedFolder & FILENAME
If Len(Dir(FilePath)) = 0 Then Title = "File not found"
End If
If Len(SharedFolder) = 0 Then
If MsgBox(PROMPT:=PROMPT, Buttons:=vbYesNo, Title:=Title) = vbYes Then
setSharedFolder
Else
Exit Sub
End If
End If
Loop Until Len(Dir(FilePath))
UpdateWorkBook FilePath
ToggleEvents True, True
End Sub

Excel VBA compare two workbooks write difference to text file

After much struggle with syntax, I have following code working, but I want to use error checking to determine if file is already open using a string.
(Disclosure: I have copied comparesheets from source that I will link when I find it)
Trying to replace this code
Set wbkA = Workbooks.Open(FileName:=wba)
with
Set wBook = Workbooks(wba) 'run time error subscript out of range
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(FileName:=wba)
End If
But I have syntax problem with the string wba. What is proper way use string here?
Sub RunCompare_WS2()
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wBook As Workbook
wba = "C:\c.xlsm"
wbb = "C:\d.xlsm"
'Set wBook = Workbooks(FileName:=wba) 'compiler error named argument not found
'Set wBook = Workbooks(wba) 'run time error subscript out of range
'If wBook Is Nothing Then
'Set wbkA = Workbooks.Open(FileName:=wba)
'End If
Set wbkA = Workbooks.Open(FileName:=wba)
Set wbkB = Workbooks.Open(FileName:=wbb)
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\comp-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub
You can use On Error Resume Next to ignore any error:
Const d As String = "C:\"
wba = "c.xlsm"
On Error Resume Next
Set wBook = Workbooks(wba)
On Error Goto 0
If wBook Is Nothing Then
Set wbkA = Workbooks.Open(d & wba) 'join string d & wba
End If
This will check to see if you have the file open.
Option Explicit
Function InputOpenChecker(InputFilePath) As Boolean
Dim WB As Workbook
Dim StrFileName As String
Dim GetFileName As String
Dim IsFileOpen As Boolean
InputOpenChecker = False
'Set Full path and name of file to check if already opened.
GetFileName = Dir(InputFilePath)
StrFileName = InputFilePath & GetFileName
IsFileOpen = False
For Each WB In Application.Workbooks
If WB.Name = GetFileName Then
IsFileOpen = True
Exit For
End If
Next WB
If you dont have it open, check to see if someone else does.
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open StrFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
'Set the FileLocked Boolean value to true
FileLocked = True
Err.Clear
End If
And one reason for your error could be the inclusion of "FileName:=" in the Workbooks.Open. Try;
Set wbkA = Workbooks.Open(wba)
Set wbkB = Workbooks.Open(wbb)
Fixed my code and reposting with corrections for clarity.
Note I moved to C:\temp since writing to root C:\ folder should not be used because many work computers have root folder locked for security as my colleague just found out!
Sub RunCompare_WS9() 'compare two WKbooks, all sheets write diff to text file
Dim i As Integer
Dim wba, wbb As String
Dim FileName As Variant
Dim wkbA As Workbook
Dim wkbB As Workbook
Dim wbook1 As Workbook
Dim wbook2 As Workbook
wba = "C:\test\c.xlsm"
wbb = "C:\test\d.xlsm"
On Error Resume Next
Set wbook1 = Workbooks(wba)
On Error GoTo 0
If wbook1 Is Nothing Then
Set wbkA = Workbooks.Open(wba)
End If
On Error Resume Next
Set wbook2 = Workbooks(wbb)
On Error GoTo 0
If wbook2 Is Nothing Then
Set wbkB = Workbooks.Open(wbb)
End If
For i = 1 To Application.Sheets.Count
Call compareSheets(wbkA.Sheets(i), wbkB.Sheets(i))
Next i
wbkA.Close SaveChanges:=True
wbkB.Close SaveChanges:=False
MsgBox "Completed...", vbInformation
End Sub
Sub compareSheets(shtSheet1 As Worksheet, shtSheet2 As Worksheet)
Dim mycell As Range
Dim mydiffs As Integer
Dim DifFound As Boolean
DifFound = False
sDestFile = "C:\Test\comp2-wb.txt"
DestFileNum = FreeFile()
Open sDestFile For Append As DestFileNum
'For each cell in sheet2 that is not the same in Sheet1, color it lightgreen in first file
For Each mycell In shtSheet1.UsedRange
If Not mycell.Value = shtSheet2.Cells(mycell.Row, mycell.Column).Value Then
If DifFound = False Then
Print #DestFileNum, "Row,Col" & vbTab & vbTab & "A Value" & vbTab & vbTab & "B Value"
DifFound = True
End If
mycell.Interior.Color = 5296274 'LightGreen
Print #DestFileNum, mycell.Row & "," & mycell.Column, mycell.Value, shtSheet2.Cells(mycell.Row, mycell.Column).Value '& vbInformation
mydiffs = mydiffs + 1
End If
Next
Print #DestFileNum, mydiffs & " differences found in " & shtSheet1.Name
Close #DestFileNum
End Sub

Merging multiple worksheets with Images into one workbook - Image error

I just started using VBA and I've been using a code to merge multiple worksheets into a single workbook, it works fine except for worksheets containing images. In these cases the image won't show in the new workbook created. It appears the box where the image should be with an error message. I use MS Office 2010.
Here follows the code I've been using:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Any idea of what is going on? I'd appreciate any help!
Tks!
just found a workaround that helped!
I just added "Application.ScreenUpdating = True" before closing the source workbook, it takes longer to merge all worsheets, but at least the images are displayed correctly!
Here follows the new code:
Sub MergePlans()
Dim CurFile As String, DirLoc As String
Dim DestWB As Workbook
Dim ws As Object
DirLoc = ThisWorkbook.Path & "\Merge\"
CurFile = Dir(DirLoc & "*.xlsx")
Application.ScreenUpdating = False
Application.EnableEvents = False
Set DestWB = Workbooks.Add(xlWorksheet)
Do While CurFile <> vbNullString
Dim OrigWB As Workbook
Set OrigWB = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True)
For Each ws In OrigWB.Sheets
ws.Select
ws.Copy After:=DestWB.Sheets(DestWB.Sheets.Count)
Next
**Application.ScreenUpdating = True**
OrigWB.Close Savechanges:=False
CurFile = Dir
Loop
Application.DisplayAlerts = False
DestWB.Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Set DestWB = Nothing
End Sub
Found this workaround here - Option 1!
Tks Dan!

Using vba i need to find a certain Trade ID within a folder with over 1000 workbooks and then open it

I have recently started using VBA code, and after several hours searching the web for ideas or help i have run into a wall.
Since this site seems to get the best reponses, i was wandering if someone could help me figure out how to Find a certain Trade ID which consists of three letters which are either; VAL, DIV, or LIF; and then a series of numbers.
My Idea was to have the Trade ID typed into a cell, for example C4, and then click a button on the same sheet that would search the entire folder for that trade ID, since they are very unique only 1 file should open maybe two.
Thanks and let me know your thoughts and whether it is possible and how long it would take me to write this code and what sort of code i should use!
Edit:
Here is my code so far:
Private Sub CommandButton1_Click()
Dim MyObj As Object, MySource As Object, file As Variant
file = Dir("X:\Ops\Trades\Repository\")
While (file <> "")
If InStr(file, Cells(3, 4)) > 0 Then
MsgBox "found " & file
Exit Sub
End If
file = Dir
Wend
End Sub
Edit:
Some Code I found and edited, however just crashes my pc when i run it.
'Definitions
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim CellSearchBook As Worksheet
Dim strFile As String
strFile = Application.GetOpenFilename
Set CellSearchBook = Workbooks.Open(strFile).Sheets(1)
CellRef = InputBox("Please enter Horseshoe Cell Reference to search for")
MyPath = "F:\Ops\Trades\Files\"
'If no files found
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If
'Array myfiles will be filled
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Run through all files
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
Dim ws As Worksheet
For Each ws In mybook.Worksheets
If .ProtectContents = True Then
With ws
Application.ScreenUpdating = False
If InStr(1, ws.Range("K11").Value, CellRef, vbTextCompare) <> 0 Then
ws.Range("H1").Copy Destination:=CellSearchBook.Range("A10")
Application.CutCopyMode = False
Else
End If
Else
ErrorYes = True
End If
End With
If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If
Next Fnum
End If
End Sub
If this helps you - it returns an array of filenames:
Private Function GetFileList(FileSpec As String) As Variant
' Returns an array of filenames that match FileSpec
' If no matching files are found, it returns False
Dim FileArray() As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
'Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
You need something like this (This is quickly spliced together from some different modules that I have, so it may not work out of the box):
Dim FolderObj, FSO, FileObj As Object
Dim FolderDialog As FileDialog
Dim FolderLocation As String
Dim Check As Boolean
'Create and run dialog box object
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = "C:\"
.InitialView = msoFileDialogViewDetails
If .Show = -1 Then
FolderLocation = .SelectedItems.Item(1)
Check = True
Else
Check = False
End If
End With
'Check if user canceled dialog box
'Exit if yes
If Check = False Then
MsgBox "No Folder Selected"
Exit Sub
End If
'Create a File System Object to be the folder that was selected
Set FSO = CreateObject("scripting.filesystemobject")
Set FolderObj = FSO.getfolder(FolderLocation)
Dim ExApp As Excel.Application
Dim ExWbk As Workbook
Set ExApp = New Excel.Application
ExApp.Visibility = False 'Set the application visibility to false to speed it up and run in the background while it searches your workbooks
For Each FileObj In FolderObj.Files
If Right(FileObj.Name, 3) = "xls" Then
Set ExWbk = ExApp.Workbooks.Open(FolderObj & "\" & FileObj.Name)
'Some sort of search for the workbook
'Some sort of return to your workbook
ExWbk.Close
end if
Next
Again, this doesn't exactly solve your problem, but it does give you a pretty decent starting point

Searching excel files for specific sheets to create a list

I have worked on this for a while. It's my first Excel VBA macro and I think I am almost there. I just can't seem to find a way to get the information I need from my function or I can't get my function to give me the right information.
I need a macro that will search through a selected folder and its sub-folders for excel workbooks that have specific sheet names contained with in then out put the paths to an excel spreadsheet. Currently my code will either only find the files in a single folder or it will list all the files indiscriminately. Now the code is a bit of a mess because i am unsure of which parts I need and which parts I don't.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim SourceFolder As String
Dim FileList As Variant
Dim GrabSheet As String
Dim FileType As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim FileToWriteTo As Variant
Dim xRow As Long
Dim xDirect$, xFname$, InitialFoldr$
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr$ = "C:"
'Define filetype
FileType = "*.xlsx"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr$
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'If user selects folder count the items to search
xDirect$ = MyDir & "\"
xFname$ = Dir(xDirect$, 8)
'Creates list with filenames
FileList = ListFiles(xDirect$ & FileType)
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(FileList)
'Opens file
Workbooks.Open (xDirect$ & FileList(i))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname$ = Dir(xDirect$ & FileList(i))
Do While xFname$ <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = xDirect$ & xFname$
xRow = xRow + 1
xFname$ = Dir
Loop
'Copies sheet
'ActiveWorkbook.Sheets(GrabSheet).Copy after:=Workbooks(ActWorkBk).Sheets(Workbooks(ActWorkBk).Sheets.Count)
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
' End If
'End With
'End Function
End Sub
'WITH SUBFOLDERS - Function that creates an array with all the files in the folder
Private Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function
'WITHOUT SUBFOLDERS - Function that creates an array with all the files in the folder
Function ListFiles(Source As String) As Variant
Dim GetFileNames() As Variant
Dim i As Integer
Dim FileName As String
On Error GoTo ErrHndlr
i = 0
FileName = Dir(Source)
If FileName = "" Then GoTo ErrHndlr
'Loops until no more mathing files are found
Do While FileName <> ""
i = i + 1
ReDim Preserve GetFileNames(1 To i)
GetFileNames(i) = FileName
FileName = Dir()
Loop
ListFiles = GetFileNames
On Error GoTo 0
Exit Function
'If error
ErrHndlr:
ListFiles = False
On Error GoTo 0
End Function
This will work right now to give a list using the "ListFiles" Function.
But I can't seem to figure out how to get it to out put a list using the "SearchFiles" Function. Which, ultimately,is what I need it to do.
Please help i feel like I am so close!!!
Ok i figured it out. I was having trouble with the syntax to access my array of arrays. here is the code that ended up doing the trick.
Option Explicit
Public ObjFolder As Object
Public objFso As Object
Public objFldLoop As Object
Public lngCounter As Long
Public objFl As Object
Sub ImportSheet()
Dim i As Integer
Dim GrabSheet As String
Dim ActWorkBk As String
Dim ImpWorkBk As String
Dim NoImport As Boolean
Dim xRow As Long
Dim xFname As String
Dim InitialFoldr As String
Dim MyDir As String, myList()
'Startup folder to begin filedialog search
InitialFoldr = "C:\Users\george.EASYWAY\Desktop\TEST1\"
'Define sheetname to copy
GrabSheet = Application.InputBox(prompt:="Please enter name of sheet you wish to find.", Default:="snagit", Title:="Specify Sheet Name")
'open dialog for user to select a folder to search
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder to list Files from"
.InitialFileName = InitialFoldr
If .Show = True Then
MyDir = .SelectedItems(1)
End If
End With
On Error Resume Next
myList = SearchFiles(MyDir, "*.xlsx", 0, myList())
If Err = 0 Then
'Imports data
Application.ScreenUpdating = False
ActWorkBk = ActiveWorkbook.Name
NoImport = False
'Clear contents of Active sheet and set active cell to A1
Sheets(1).UsedRange.ClearContents
Sheets(1).Select
Range("A1").Select
For i = 1 To UBound(myList, 2)
'Opens file
Workbooks.Open (myList(1, (i)) & "\" & (myList(2, (i))))
ImpWorkBk = ActiveWorkbook.Name
'Checks to see if the specific sheet exists in the workbook
On Error Resume Next
ActiveWorkbook.Sheets(GrabSheet).Select
If Err > 0 Then
NoImport = True
GoTo nxt
End If
Err.Clear
On Error GoTo 0
xFname = Dir(myList(1, (i)) & "\" & (myList(2, (i))))
Do While xFname <> ""
ThisWorkbook.Activate
ActiveCell.Offset(xRow) = (myList(1, (i)) & "\" & (myList(2, (i))))
xRow = xRow + 1
xFname = Dir
Loop
'Renames the imported sheet
On Error Resume Next
ActiveSheet.Name = "Specs with " & GrabSheet
Err.Clear
On Error GoTo 0
nxt:
'Closes importfile
Workbooks(ImpWorkBk).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Saved = True
ActiveWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True
'Workbooks(ActWorkBk).Activate
Next i
'Error if some sheets were not found
' If NoImport = True Then MsgBox "Some of the files did not contain the sheet " & GrabSheet
Application.ScreenUpdating = True
Else
MsgBox "No file found"
End If
On Error GoTo 0
End Sub
'Function that creates an array with all the files in the folder with subfolders
Function SearchFiles(MyDir As String, myFileName As String, n As Long, myList()) As Variant
Dim fso As Object, myFolder As Object, myFile As Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each myFile In fso.getfolder(MyDir).Files
If (Not myFile.Name Like "~$*") * (myFile.Name <> ThisWorkbook.Name) _
* (myFile.Name Like myFileName) Then
n = n + 1
ReDim Preserve myList(1 To 2, 1 To n)
myList(1, n) = MyDir
myList(2, n) = myFile.Name
End If
Next
For Each myFolder In fso.getfolder(MyDir).subfolders
SearchFiles = SearchFiles(myFolder.Path, myFileName, n, myList)
Next
SearchFiles = IIf(n > 0, myList, "")
End Function