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

Version 1 link: http://naumankhan.blogspot.com/2010/09/vbamacro-code-for-excel-2010-to-combine.html

Upgrades in Version 2:

· Auto save of all output excel files

· Text File generation and auto save for all output files

· Detection for already existing files

· One Button Execution

   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: On Error Resume Next  23: If Workbooks(Filename3) Is Nothing Then     ' checking if output file is not already open  24:     If Dir(Path1 + Filename3) = vbNullString Then  ' checking if file already doesn't exists  25:         'File doesn't exist then Create PSR output file  26:         Dim MyXL As Object  'Excel Application Object  27:         Set MyXL = CreateObject("Excel.Application")    'Create the Excel Application Object  28:         MyXL.Workbooks.Add      'Create new Excel Workbook  29:         MyXL.Worksheets(1).SaveAs (Path1 + Filename3)  'Save the Excel File  30:         MyXL.Quit   'Close the Excel Window and / or Application in background  31:     Else    ' if file exists, display msg and exit macro  32:         MsgBox "Output file already exists! please delete it before executing this macro"  33:         Exit Sub  34:     End If  35: Else  36:     MsgBox "Output file already exists! please delete it before executing this macro"  37:     Exit Sub  38: End If  39:    40: Workbooks.Open Filename:=Path1 + Filename1       ' open PSR input file 1  41: Sheets("Sheet1").Select     ' activate sheet  42: Range("A10").Select     ' select fixed cell  43: Range(Selection, Selection.End(xlToRight)).Select   ' selecting all columns  44: Range(Selection, Selection.End(xlDown)).Select      ' selecting all rows  45: Selection.Copy      ' copying selection  46:    47: Workbooks.Open Filename:=Path1 + Filename3       ' open PSR output file  48: Windows(Filename3).Activate     ' activating output file  49: Sheets("Sheet1").Select     ' activate sheet  50: Range("A1").Select      ' select cell  51: ActiveSheet.Paste       ' pasting PSR input file 1 values in output file  52:    53: Workbooks.Open Filename:=Path1 + Filename2       ' open PSR input file 2  54: Sheets("Sheet1").Select     ' activate sheet  55: Range("A11").Select     ' select cell  56: Range(Selection, Selection.End(xlToRight)).Select   ' selecting all columns  57: Range(Selection, Selection.End(xlDown)).Select      ' selecting all rows  58: Application.CutCopyMode = False     ' disabling copy/paste popup msgs  59: Selection.Copy      ' copying selection  60:    61: Windows(Filename3).Activate     ' activating output file  62: Sheets("Sheet1").Select     ' activating sheet  63: Cells(Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row, 1).Select    ' selecting first empty cell in 1st column  64: ActiveSheet.Paste       ' pasting PSR input file 2 values in output file  65:    66: Workbooks(Filename1).Close SaveChanges:=False   ' closing PSR input file 1  67: Workbooks(Filename2).Close SaveChanges:=False   ' closing PSR input file 2  68:    69: Columns("A:A").Select   ' select 1st column  70: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _  71:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _  72:     Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _  73:     :=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  74: Range("A1").FormulaR1C1 = "Date"    ' Setting 1st column's header = Date  75: Columns("B:B").Select   ' select 2nd column  76: Selection.NumberFormat = "h:mm:ss;@"    ' setting datatype = time  77: Columns("D:D").Select   ' selecting 4th column  78: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove  ' inserting a new blank column  79: Columns("C:C").Select   ' selecting 3rd column  80: Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _  81:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _  82:     Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _  83:     :="/", FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True   ' dividing 3rd column into 2 columns containing msc name and node, setting datetypes = txt  84: Range("C1").FormulaR1C1 = "MSC"     ' Setting 3rd column's header = MSC  85: Range("D1").FormulaR1C1 = "Node"    ' Setting 4th column's header = Node  86:    87: Columns("A:A").Select   ' select 1st column  88: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove  ' inserting a new blank column  89: Range("A1").FormulaR1C1 = "Week"    ' Setting 1st column's header = Week  90: Range("A2").FormulaR1C1 = Week1     ' Setting 1st column's 2nd value = Week from macros sheet  91: Range("A2").Select      ' selecting 1st column's 2nd cell  92: Selection.AutoFill Destination:=Range(Cells(2, 1), Cells(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row, 1)), Type:=xlFillCopy  ' filling 1st column with week from macros sheet  93:    94: Range("R1").FormulaR1C1 = "Voice PSR"   ' Setting 18th column's header = Voice PSR  95: Range("S1").FormulaR1C1 = "SMS PSR"     ' Setting 19th column's header = SMS PSR  96:    97: Range("R2").FormulaR1C1 = "=IF(RC[-10]<>0,((RC[-4]+RC[-3])/RC[-10]%),"""")"     ' inserting Voice PSR formula in 18th Column's 2nd cell  98: Range("S2").FormulaR1C1 = "=IF(RC[-9]<>0,((RC[-3]+RC[-2])/RC[-9]%),"""")"       ' inserting SMS PSR formula in 19th Column's 2nd cell  99:   100: Range("R2").Select      ' coping formula in whole 18th column 101: Selection.AutoFill Destination:=Range(Cells(2, 18), Cells(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row, 18)) 102: Range("S2").Select      ' coping formula in whole 19th column 103: Selection.AutoFill Destination:=Range(Cells(2, 19), Cells(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row, 19)) 104:   105: Windows(Filename3).Activate     'activating output file 106: ActiveWorkbook.Close SaveChanges:=True      'saving and closing output file 107: Workbooks.Open Filename:=Path1 + Filename3      'opening output file again 108: Windows(Filename3).Activate     'activating output file 109: ActiveWorkbook.SaveAs Path1 + "PSR.txt", FileFormat:=-4158      'saving output file as txt file 110: Windows("PSR.txt").Activate     'activating txt file 111: ActiveWindow.Close SaveChanges:=True        'saving and closing txt file 112: Workbooks.Open Filename:=Path1 + Filename3      'opening output file 113: Windows("Dashboard Macros.xlsm").Activate   ' activate dashboard window 114:   115: Application.DisplayAlerts = True    ' enabling popup alerts 116: Application.ScreenUpdating = True   ' enabling screen updating 117: End Sub

   1: Sub Execute()   'calling all macros   2:     Call PSR   3:     Call HOSR   4:     Call SMS   5:     Call MASR   6:     Call CSSR   7:     Call LUSR   8:     Call CM_AUTH_CIPHER   9:     Call VLR  10:     Call MOCSR  11:     Call MTCSR  12: End Sub