urShadow's Blog: VBA/Macro Code for Excel 2010 to combine two files based on certain criteria and perform some post processing

   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