I have the following code:
Option Explicit
Sub Consolidate()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean
Dim DCLastRow As Integer 'DirectorCopy
Dim MCLastRow As Integer 'Monthly Compiler
Dim CMonth As String 'Compile Month
Dim CYear As String 'Compile Year
Dim Month As Integer
Dim MonthFilter As String
Dim center(18) As String
center(1) = "Bardstown"
center(2) = "Bothell"
center(3) = "VCollinsville"
center(4) = "El Paso"
center(5) = "Evansville"
center(6) = "Greensboro"
center(7) = "VHeathrow"
center(8) = "Joplin"
center(9) = "Kennesaw"
center(10) = "Lafayette"
center(11) = "Malvern"
center(12) = "VManhattan"
center(13) = "VMansfield"
center(14) = "VOttawa"
center(15) = "VPonco City"
center(16) = "VReno"
center(17) = "VSioux City"
center(18) = "VTerra Haute"
Dim FileCount As Long
Dim ScoringAve As Double
Dim i As Long
' If Cells(13, 4).Value = "January" Then Month = 1
' If Cells(13, 4).Value = "February" Then Month = 2
' If Cells(13, 4).Value = "March" Then Month = 3
' If Cells(13, 4).Value = "April" Then Month = 4
' If Cells(13, 4).Value = "May" Then Month = 5
' If Cells(13, 4).Value = "June" Then Month = 6
' If Cells(13, 4).Value = "July" Then Month = 7
' If Cells(13, 4).Value = "August" Then Month = 8
' If Cells(13, 4).Value = "September" Then Month = 9
' If Cells(13, 4).Value = "October" Then Month = 10
' If Cells(13, 4).Value = "November" Then Month = 11
' If Cells(13, 4).Value = "December" Then Month = 12
' CMonth = MonthName(Month, True)
'This one line of code replaces the above 13 lines
CMonth = Left(Cells(13, 4).Value, 3)
CYear = Right(Cells(13, 7).Value, 2)
'Fill in the path\folder where the files are
MyPath = "X:\C&A Analysts Team\PF Process\1 Tally & PF's Work in
Progress\Centers\"
For i = 1 To 18
' 'Add a slash at the end if the user forget it
' If Right(MyPath, 1) <> "\" Then
' MyPath = MyPath & "\"
' End If
'If there are no Excel files in the folder exit the sub
MonthFilter = MyPath & center(i) & "\*" & CMonth & " " & CYear &
"*.xl*"
FilesInPath = Dir(MonthFilter)
If FilesInPath = "" Then
MsgBox "No files found in " & center(i)
GoTo ContinueLoop
End If
If FilesInPath <> "" Then
FileCount = FileCount + 1
End If
'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
If InStr(1, FilesInPath, CMonth & " " & CYear, vbTextCompare) Then
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
End If
Loop
'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & center(i) & "\" &
MyFiles(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
'Need to do the following:
'if lazy eye hasn't been run in directorcopy then run it
With mybook.Worksheets("DirectorCopy")
If .Cells(1, 1) = "" Then
Application.Run "DirectorFormat"
With Application.Run I'm getting the following error:
Cannot run the macro 'DirectorFormat'. The macro may not be available in
this workbook or all macros may disabled.
Here is the code for DirectorFormat:
Sub DirectorFormat()
Dim TSLastPFRow As Integer 'Tally Sheet
Dim TSPFTotal As Integer 'Tally Sheet PF
Dim ZeroRow As Long, i As Long
With Sheets("Tally Sheet")
.Cells.Copy
.Paste Destination:=Worksheets("DirectorCopy").Range("A1")
End With
With Worksheets("DirectorCopy")
'.Shapes("LazyEyeButton").Cut
For j = 1 To 64
.Shapes("Done! " & j).Cut
Next
.Columns("G:G").Delete
.Cells.Copy
.Cells.PasteSpecial Paste:=xlPasteValues,
Operation:=xlPasteSpecialOperationNone, _
SkipBlanks:=False, Transpose:=False
'Find the last PF
For i = 4 To Rows.Count Step 8
If Cells(i, "A").Value = 0 Then
ZeroRow = i
Exit For
End If
Next
TSLastPFRow = ZeroRow - 9
TSPFTotal = (Val(Replace(Cells(TSLastPFRow, 1).Value, "_PF", "")))
'Delete empty PFs at the bottom
.Range(ZeroRow & ":515").Delete
'Delete all title bars except the first one
For i = (ZeroRow - 7) To 13 Step -8
.Rows(i).Delete
Next
.Rows("4:4").Select
ActiveWindow.FreezePanes = True
End With
End Sub
It's not set to private and I don't have my macros disabled. The code isn't
that long so I suppose I could just duplicate it in this macro but that seems
like "poor coding" to me if it's already somewhere else. What am I doing
wrong?
|
Similar Threads
