Hello, My skills in vba are limited. I've had this macro forever and now that we moved our files to SharePoint, it is not working. The macro loops thru files and then extracts line items that meet a certain criteria, everything works except it stops at the Dir function with error of Run-Time error '52': Bad file name or number. Font is in red where it crashes. I would appreciate any help.
Rich (BB code):
Option Base 1
Dim aFiles() As String, iFile As Integer
Sub LoopFoldersandSubfolders()
Dim Counter As Integer
Dim DataA(1000) As String
Dim My_Range As Range
Dim My_Cell As Variant
Dim PropNum As String
Dim sSourcePath As String
Dim sDestinationPath As String
WB1 = ActiveWorkbook.Name
LastRow = Range("A6000").End(xlUp).Row
Worksheets("Report").Select
PLastRow = Range("A60000").End(xlUp).Row
If PLastRow > 5 Then
Rows("6:" & PLastRow).Select
Selection.ClearContents
End If
Dim TargetFileName As String
Dim ObjFolder As Object
Dim DtMo As String
Dim DtYe As String
Workbooks(WB1).Activate
Worksheets("Options").Select
DtMo = Range("F7").Value
If DtMo < 10 Then
DtMo = 0 & DtMo
End If
DtYe = Range("F8").Value
TargetFileName = "\\CompanyName/Accounting\Capital Review\" & DtYe & "\" & DtMo & "." & DtYe & " Capital Workbooks\"
'Calls ListFilesInDirectory procedure
iFile = 0
ListFilesInDirectory TargetFileName
'Loops through files and performs code
For Counter = 1 To iFile
Application.StatusBar = Round(((Counter / iFile) * 100), 0) & "%"
sName = aFiles(Counter)
fname = Right(sName, Len(sName) - Len(TargetFileName))
On Error Resume Next
Set bk = Workbooks.Open(sName, ReadOnly:=False, WriteResPassword:="xxxx", UpdateLinks:=False, ignorereadonlyrecommended:=True)
If Err.Number <> 0 Then
MsgBox "Problems with " & sName
Else
On Error GoTo 0
WB2 = ActiveWorkbook.Name
WB2Path = ActiveWorkbook.FullName
'****************Code Goes Here****************
StartRow = Range("L1").End(xlDown).Row
LastRow = Range("L60000").End(xlUp).Row
Cells(StartRow + 1, 13).Select
Do Until ActiveCell.Row = LastRow + 1
If ActiveCell.Value <> "" Then
ActiveCell.EntireRow.Copy
Workbooks(WB1).Activate
Sheets("Report").Select
LastRow2 = Range("L60000").End(xlUp).Row
Cells(LastRow2 + 1, 1).Select
ActiveCell.EntireRow.PasteSpecial xlValues
Workbooks(WB2).Activate
Application.CutCopyMode = False
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveWorkbook.Close SaveChanges:=False
End If
On Error GoTo 0
Next
Exit Sub
End Sub
Private Sub ListFilesInDirectory(Directory As String)
Dim aDirs() As String, iDir As Integer, stFile As String
' Uses Dir function to find files and folders in selected Directory
' Looks for directories and builds a separate array of them
' Note that Dir returns files as well as directories when vbDirectory is specified
iDir = 0
stFile = Directory & Dir(Directory & "*.*", vbDirectory)
Do While stFile <> Directory
If Right(stFile, 2) = "\." Or Right(stFile, 3) = "\.." Then
Else
'Adds to global array of files if it is an Excel workbook
If InStr(1, stFile, ".xls", vbTextCompare) > 0 Then
iFile = iFile + 1
ReDim Preserve aFiles(iFile)
aFiles(iFile) = stFile
End If
End If
stFile = Directory & Dir()
Loop
'For any directories in aDirs calls self recursively
If iDir > 0 Then
For iDir = 1 To UBound(aDirs)
ListFilesInDirectory aDirs(iDir) & Application.PathSeparator
Next iDir
End If
End Sub
