Thursday, September 2, 2010

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

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


http://blogs.technet.com/b/office2010/archive/2009/07/21/office-2010-application-security.aspx?PageIndex=2


http://blogs.technet.com/b/office2010/archive/2009/07/21/office-2010-application-security.aspx?PageIndex=3#comments


creating excel file


http://www.mrexcel.com/archive/VBA/18884.html


http://www.tech-archive.net/Archive/Access/microsoft.public.access.externaldata/2008-01/msg00164.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

Related Posts Plugin for WordPress, Blogger...