J
Jim May
The below code works PREFECTLY on my Exccel 2003 - Windows PC
I took it out to a client's office this morning and we spent 2 hours
trying to get the Macro ExtractDataFromFiles() to run -- all without
success.
Our initial problem started with line 2 - where I needed to replace
Const.... with the area on the Mac HD... neither he or I knew exactly
How to do it... We might have fixed it because we 30 minutes later
noticed the code stopped on the line:
UserForm1.Show vbModeless << with the keyword vbmodeless highlite < so
I ''
Commented it out and things seemed to run a bit further,, but anyway it
ended
Up being a 2 hour fiasco, unfortunately, and I was so proud of what I
had
Done on my windows PC,, grrrrrr
Can anyone offer some help here - He has an uptodate Macintosh (sorry
don't
Know versions of it or his excel ver,,,
Thanks,
Option Explicit
Option Base 1
Sub ExtractDataFromFiles()
Const sPath = "C:\Documents and Settings\Jim May\My Documents\Boatwright
Stan\Projects\Lodging_Technology\Contracts\"
Dim sName As String
Dim wb As Workbook
Dim j As Integer
Dim n As Integer
Dim r(1 To 14) As Variant
ActiveSheet.Range("A6:N2000").ClearContents
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sName = Dir(sPath & "PA*.xls")
j = 6 ' Data starts on Row 6
MsgBox "There are " & FileCount(sPath) & " Qualifying Files"
UserForm1.Show vbModeless
Do While sName <> ""
Set wb = Workbooks.Open(sPath & sName)
With wb.Worksheets("Cost Analysis")
r(1) = .Range("J2").Value
r(2) = .Range("B4").Value
r(3) = .Range("B6").Value
r(4) = .Range("G4").Value
r(5) = Left(.Range("G6").Value, Len(.Range("G6")) - 2)
r(6) = Right(.Range("G6").Value, 2)
r(7) = .Range("J1").Value
r(8) = .Range("G51").Value
r(9) = .Range("G53").Value
r(10) = .Range("G54").Value
r(11) = .Range("G56").Value
r(12) = .Range("G57").Value
r(13) = .Range("G58").Value
r(14) = .Range("G59").Value
End With
wb.Close SaveChanges:=False
DoEvents
UserForm1.Repaint
With ThisWorkbook.ActiveSheet
For n = 1 To 14
..Cells(j, n).Value = r(n)
Next n
End With
j = j + 1
sName = Dir
Loop
Range("G3").Value = Now()
AutoFilterOn
UserForm1.Hide
Unload UserForm1
End Sub
Function FileCount(FolderName As String, _
Optional FileFilter As String = "PA*.xls", _
Optional FileTypes As Long = 1, _
Optional SubFolders As Boolean = False) As Long
With Application.FileSearch
.NewSearch
.LookIn = FolderName
.SearchSubFolders = SubFolders
.Filename = FileFilter
.MatchTextExactly = True
.FileType = FileTypes
.Execute
FileCount = .FoundFiles.Count
End With
End Function
Sub AutoFilterOn()
If Sheets("Main").AutoFilterMode = False Then
Range("A5:N5").AutoFilter
End If
End Sub
I took it out to a client's office this morning and we spent 2 hours
trying to get the Macro ExtractDataFromFiles() to run -- all without
success.
Our initial problem started with line 2 - where I needed to replace
Const.... with the area on the Mac HD... neither he or I knew exactly
How to do it... We might have fixed it because we 30 minutes later
noticed the code stopped on the line:
UserForm1.Show vbModeless << with the keyword vbmodeless highlite < so
I ''
Commented it out and things seemed to run a bit further,, but anyway it
ended
Up being a 2 hour fiasco, unfortunately, and I was so proud of what I
had
Done on my windows PC,, grrrrrr
Can anyone offer some help here - He has an uptodate Macintosh (sorry
don't
Know versions of it or his excel ver,,,
Thanks,
Option Explicit
Option Base 1
Sub ExtractDataFromFiles()
Const sPath = "C:\Documents and Settings\Jim May\My Documents\Boatwright
Stan\Projects\Lodging_Technology\Contracts\"
Dim sName As String
Dim wb As Workbook
Dim j As Integer
Dim n As Integer
Dim r(1 To 14) As Variant
ActiveSheet.Range("A6:N2000").ClearContents
Application.ScreenUpdating = False
Application.DisplayAlerts = False
sName = Dir(sPath & "PA*.xls")
j = 6 ' Data starts on Row 6
MsgBox "There are " & FileCount(sPath) & " Qualifying Files"
UserForm1.Show vbModeless
Do While sName <> ""
Set wb = Workbooks.Open(sPath & sName)
With wb.Worksheets("Cost Analysis")
r(1) = .Range("J2").Value
r(2) = .Range("B4").Value
r(3) = .Range("B6").Value
r(4) = .Range("G4").Value
r(5) = Left(.Range("G6").Value, Len(.Range("G6")) - 2)
r(6) = Right(.Range("G6").Value, 2)
r(7) = .Range("J1").Value
r(8) = .Range("G51").Value
r(9) = .Range("G53").Value
r(10) = .Range("G54").Value
r(11) = .Range("G56").Value
r(12) = .Range("G57").Value
r(13) = .Range("G58").Value
r(14) = .Range("G59").Value
End With
wb.Close SaveChanges:=False
DoEvents
UserForm1.Repaint
With ThisWorkbook.ActiveSheet
For n = 1 To 14
..Cells(j, n).Value = r(n)
Next n
End With
j = j + 1
sName = Dir
Loop
Range("G3").Value = Now()
AutoFilterOn
UserForm1.Hide
Unload UserForm1
End Sub
Function FileCount(FolderName As String, _
Optional FileFilter As String = "PA*.xls", _
Optional FileTypes As Long = 1, _
Optional SubFolders As Boolean = False) As Long
With Application.FileSearch
.NewSearch
.LookIn = FolderName
.SearchSubFolders = SubFolders
.Filename = FileFilter
.MatchTextExactly = True
.FileType = FileTypes
.Execute
FileCount = .FoundFiles.Count
End With
End Function
Sub AutoFilterOn()
If Sheets("Main").AutoFilterMode = False Then
Range("A5:N5").AutoFilter
End If
End Sub