Howdy,
I would like to know all I can currently run macros in multiple workbooks I have in one directory. At the moment I am opening up around 75 different workbooks and running them individually. I have provided the code below which is the macro I use.
The directory is P:\PETERB\ASSETS\Capex\Cap 2012\Monthly Reports for PM's\"Period month year"
Many thanks in Advance.
I would like to know all I can currently run macros in multiple workbooks I have in one directory. At the moment I am opening up around 75 different workbooks and running them individually. I have provided the code below which is the macro I use.
The directory is P:\PETERB\ASSETS\Capex\Cap 2012\Monthly Reports for PM's\"Period month year"
Many thanks in Advance.
Code:
Sub UpdatePMReport()
'
' CopyDataIntoSheetPO Macro
' Macro recorded 24/03/2011 by Mark Proctor
'
Application.ScreenUpdating = False
'Define Variables
Dim CapExNo As Range
Set CapExNo = Sheets("Summary").Range("B5")
Dim ReportWorkbookName As Workbook
Set ReportWorkbookName = ActiveWorkbook
'Create new spreadsheet
Sheets.Add.Name = "DataSheet"
'Copy data to new sheet.
Windows("PM Reports MacroBook").Activate
Sheets("PO Info").Select
Cells.Select
Selection.Copy
ReportWorkbookName.Activate
Sheets("DataSheet").Cells.Select
ActiveSheet.Paste
'Delete Deleted Items
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:="@11@"
Rows("2:10000").Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=2
'Select the CapEx number
Selection.AutoFilter Field:=10, Criteria1:=CapExNo
'Count the number of rows
Dim rng As Range
Set rng = ActiveSheet.AutoFilter.Range
'If no lines to add then don't add anything
If rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
'Clear Contents of Analysis Sheet
Sheets("Analysis").Select
Range("A4").Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Dim FirstEmptyRow As Long
FirstEmptyRow = ActiveCell.Row
Sheets("Analysis").Select
Range("A5:K" & FirstEmptyRow - 1).ClearContents
'Insert rows into Analysis Sheet
Dim RowStart As Long
RowStart = "6"
Dim RowEnd As Long
RowEnd = RowStart + rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
Dim RowFull As Long
RowFull = rng.Rows.Count - 1
Sheets("Analysis").Select
Rows(RowStart & ":" & RowEnd).Select
Selection.Insert Shift:=xlDown
Sheets("DataSheet").Select
Range("A2:A" & RowFull).Select
Selection.Copy
Sheets("Analysis").Select
Range("A" & RowStart - 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("DataSheet").Select
Range("C2:E" & RowFull).Select
Selection.Copy
Sheets("Analysis").Select
Range("B" & RowStart - 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("DataSheet").Select
Range("L2:R" & RowFull).Select
Selection.Copy
Sheets("Analysis").Select
Range("F" & RowStart - 1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Delete Blank Rows
Sheets("Analysis").Select
Range("D" & RowEnd).Select
ActiveCell.Offset(1, 0).Select
Do While IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Dim LastEmptyRow As Long
LastEmptyRow = ActiveCell.Row
Rows(RowEnd - 1 & ":" & LastEmptyRow - 1).Delete
Else
MsgBox ("No PO's Found")
Dim NoPOs As Long
NoPOs = 1
End If
'Delete Data Sheet
Application.DisplayAlerts = False
Sheets("DataSheet").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
'Show where Foreignt Currenices have been used
Sheets("Analysis").Select
Range("L5").Select
Do
If ActiveCell.Value = "GBP" Then
ActiveCell.Value = ""
Else
ActiveCell.Interior.ColorIndex = 3
End If
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell)
'INSERT JOURNALS
'Create new spreadsheet
Sheets.Add.Name = "DataSheet"
'Copy Data Into New Worksheet
Windows("PM Reports MacroBook").Activate
Sheets("Direct Info").Select
Cells.Select
Selection.Sort Key1:=Range("R2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Copy
ReportWorkbookName.Activate
Sheets("DataSheet").Cells.Select
ActiveSheet.Paste
'Delete Journals that should not display Items
Cells.Select
Selection.AutoFilter Field:=8, Criteria1:="PFRMP11029"
Rows("2:10000").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.AutoFilter
'Select the CapEx number
Cells.Select
Selection.AutoFilter Field:=11, Criteria1:=CapExNo
'Count the number of rows
Set rng = ActiveSheet.AutoFilter.Range
If rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 > 0 Then
'Clear Contents of Analysis Sheet
Sheets("Analysis").Select
Range("A4").Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Dim JournalFirstRow As Long
JournalFirstRow = ActiveCell.Row + 2
Range("A" & JournalFirstRow).Select
ActiveCell.Offset(1, 0).Select
Do While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
Loop
Dim JournalLastRow As Long
JournalLastRow = ActiveCell.Row
Range("A" & JournalFirstRow & ":K" & JournalLastRow - 1).ClearContents
'Insert rows into Analysis Sheet
Dim RowsOfJournals As Long
RowsOfJournals = rng.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
Dim RowsOfJournalsInsert As Long
RowsOfJournalsInsert = RowsOfJournals - JournalLastRow + JournalFirstRow
Sheets("Analysis").Select
If RowsOfJournalsInsert > 0 Then
Rows(JournalFirstRow + 1 & ":" & JournalFirstRow + 1 + RowsOfJournalsInsert - 1).Select
Selection.Insert Shift:=xlDown
End If
Dim JournalRowFull As Long
JournalRowFull = rng.Rows.Count - 1
If NoPOs = 1 Then
JournalFirstRow = JournalFirstRow + 1
End If
Sheets("DataSheet").Select
Range("H2:H" & JournalRowFull).Select
Selection.Copy
Sheets("Analysis").Select
Range("A" & JournalFirstRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("DataSheet").Select
Range("I2:I" & JournalRowFull).Select
Selection.Copy
Sheets("Analysis").Select
Range("D" & JournalFirstRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("DataSheet").Select
Range("T2:T" & JournalRowFull).Select
Selection.Copy
Sheets("Analysis").Select
Range("J" & JournalFirstRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Else
MsgBox ("No Journals Found")
End If
'Delete Data Sheet
Application.DisplayAlerts = False
Sheets("DataSheet").Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub