1: Sub PSR()
2: '
3: ' PSR Macro
4: '
5: Application.DisplayAlerts = False ' disabling popup alerts
6: Application.ScreenUpdating = False ' disabling screen updating
7:
8: Dim Week1 As String ' path of the input/output files
9: Dim Path1 As String ' path of the input/output files
10: Dim Filename1 As String ' name of PSR input file 1
11: Dim Filename2 As String ' name of PSR input file 2
12: Dim Filename3 As String ' name of PSR output file
13:
14: Windows("Dashboard Macros.xlsm").Activate ' activate dashboard window
15: Sheets("Macros").Select ' activate dashboard sheet
16: Path1 = Range("C6").Text ' read path, filenames and week
17: Filename1 = Range("C8").Text
18: Filename2 = Range("C9").Text
19: Filename3 = Range("C10").Text
20: Week1 = Range("C5").Text
21:
22: ' Application.ActiveProtectedViewWindow.Edit
23:
24: Workbooks.Open Filename:=Path1 + Filename1 ' open PSR input file 1
25: Sheets("Sheet1").Select ' activate sheet
26: Range("A10").Select ' select fixed cell
27: Range(Selection, Selection.End(xlToRight)).Select ' selecting all columns
28: Range(Selection, Selection.End(xlDown)).Select ' selecting all rows
29: Selection.Copy ' copying selection
30:
31: On Error Resume Next
32: If Workbooks(Filename3) Is Nothing Then ' checking if output file is not already open
33: If Dir(Path1 + Filename3) = vbNullString Then ' checking if file already doesn't exists
34: 'File doesn't exist then Create PSR output file
35: Dim MyXL As Object 'Excel Application Object
36: Set MyXL = CreateObject("Excel.Application") 'Create the Excel Application Object
37: MyXL.Workbooks.Add 'Create new Excel Workbook
38: MyXL.Worksheets(1).SaveAs (Path1 + Filename3) 'Save the Excel File
39: MyXL.Quit 'Close the Excel Window and / or Application in background
40: End If
41: Else
42: Workbooks(Filename3).Close savechanges:=False 'if output file is open then closing it
43: End If
44:
45: Workbooks.Open Filename:=Path1 + Filename3 ' open PSR output file
46: Windows(Filename3).Activate ' activating output file
47: Sheets("Sheet1").Select ' activate sheet
48: Range("A1").Select ' select cell
49: ActiveSheet.Paste ' pasting PSR input file 1 values in output file
50:
51: Workbooks.Open Filename:=Path1 + Filename2 ' open PSR input file 2
52: Sheets("Sheet1").Select ' activate sheet
53: Range("A11").Select ' select cell
54: Range(Selection, Selection.End(xlToRight)).Select ' selecting all columns
55: Range(Selection, Selection.End(xlDown)).Select ' selecting all rows
56: Application.CutCopyMode = False ' disabling copy/paste popup msgs
57: Selection.Copy ' copying selection
58:
59: Windows(Filename3).Activate ' activating output file
60: Sheets("Sheet1").Select ' activating sheet
61: Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row, 1).Select ' selecting first empty cell in 1st column
62: ActiveSheet.Paste ' pasting PSR input file 2 values in output file
63:
64: Workbooks(Filename1).Close savechanges:=False ' closing PSR input file 1
65: Workbooks(Filename2).Close savechanges:=False ' closing PSR input file 2
66:
67: Columns("A:A").Select ' select 1st column
68: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
69: TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
70: Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
71: :=Array(Array(1, 4), Array(2, 2)), TrailingMinusNumbers:=True ' dividing 1st column into 2 columns containing date and time, setting first column's datetype = date
72: Range("A1").FormulaR1C1 = "Date" ' Setting 1st column's header = Date
73: Columns("B:B").Select ' select 2nd column
74: Selection.NumberFormat = "h:mm:ss;@" ' setting datatype = time
75: Columns("D:D").Select ' selecting 4th column
76: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove ' inserting a new blank column
77: Columns("C:C").Select ' selecting 3rd column
78: Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
79: TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
80: Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
81: :="/", FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True ' dividing 3rd column into 2 columns containing msc name and node, setting datetypes = txt
82: Range("C1").FormulaR1C1 = "MSC" ' Setting 3rd column's header = MSC
83: Range("D1").FormulaR1C1 = "Node" ' Setting 4th column's header = Node
84:
85: Columns("A:A").Select ' select 1st column
86: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove ' inserting a new blank column
87: Range("A1").FormulaR1C1 = "Week" ' Setting 1st column's header = Week
88: Range("A2").FormulaR1C1 = Week1 ' Setting 1st column's 2nd value = Week from macros sheet
89: Range("A2").Select ' selecting 1st column's 2nd cell
90: Selection.AutoFill Destination:=Range(Cells(2, 1), Cells(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row, 1)), Type:=xlFillCopy ' filling 1st column with week from macros sheet
91:
92: Range("R1").FormulaR1C1 = "Voice PSR" ' Setting 18th column's header = Voice PSR
93: Range("S1").FormulaR1C1 = "SMS PSR" ' Setting 19th column's header = SMS PSR
94:
95: Range("R2").FormulaR1C1 = "=IF(RC[-10]<>0,((RC[-4]+RC[-3])/RC[-10]%),"""")" ' inserting Voice PSR formula in 18th Column's 2nd cell
96: Range("S2").FormulaR1C1 = "=IF(RC[-9]<>0,((RC[-3]+RC[-2])/RC[-9]%),"""")" ' inserting SMS PSR formula in 19th Column's 2nd cell
97:
98: Range("R2").Select ' coping formula in whole 18th column
99: Selection.AutoFill Destination:=Range(Cells(2, 18), Cells(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row, 18))
100: Range("S2").Select ' coping formula in whole 19th column
101: Selection.AutoFill Destination:=Range(Cells(2, 19), Cells(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row, 19))
102:
103: Application.DisplayAlerts = True ' enabling popup alerts
104: Application.ScreenUpdating = True ' enabling screen updating
105: End Sub
References:
my old postings
http://naumankhan.blogspot.com/2010/02/vbamacro-code-for-excel-2007-to.html
http://naumankhan.blogspot.com/2010/01/copying-data-from-multiple-excel-files.html
to find empty cell in a column:
http://www.contextures.com/xlfaqMac.html#Empty
to check if workbook already open
http://www.ozgrid.com/VBA/IsWorkbookOpen.htm#ONE
http://www.mrexcel.com/forum/showthread.php?t=2659
http://www.mrexcel.com/forum/showthread.php?t=219
http://www.vbaexpress.com/kb/getarticle.php?kb_id=468
http://www.vbaexpress.com/kb/getarticle.php?kb_id=443
to check if file already exists
http://www.ozgrid.com/forum/showthread.php?t=141541
http://www.ozgrid.com/forum/showthread.php?t=46720&page=1
http://www.ozgrid.com/forum/showthread.php?t=15867&page=1
http://www.ozgrid.com/forum/showthread.php?t=36839&page=1
Office 2010 new security policies
creating excel file
http://www.mrexcel.com/archive/VBA/18884.html
How to: Show the Developer Tab on the Ribbon in office 2010
http://msdn.microsoft.com/en-us/library/bb608625.aspx
-urShadow
No comments:
Post a Comment