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

References:

Saving Excel file as txt or other extensions:

http://msdn.microsoft.com/en-us/library/ff458119%28office.11%29.aspx

http://blogs.msdn.com/b/excel/archive/2009/07/07/use-the-vba-saveas-method-in-excel-2007.aspx

http://www.techonthenet.com/excel/formulas/dir.php

http://www.thezcorp.com/VBACodeSamples.aspx

Deleting a file

http://www.exceltip.com/st/Basic_file_and_folder_examples_using_VBA_in_Microsoft_Excel/443.html

http://zo-d.com/blog/archives/programming/vba-writing-to-a-text-file-ms-project-excel.html

Calling multiple macros

http://www.ozgrid.com/forum/showthread.php?t=40993&page=1

-urShadow