Pages

Tuesday, January 4, 2011

VBA/Macro For Excel 2010 to process 4 csv files and generate a graphical report (version 2)

Previous Post: http://naumankhan.blogspot.com/2010/12/vbamacro-for-excel-2010-to-process-4.html

   1: Sub Execute()
   2: '
   3: ' 20100102 - Ver2
   4: ' Nauman Khan, http://naumankhan.blogspot.com, naumankhan@bigfoot.com
   5: ' Changes in ver2
   6: ' - Changed date format which is used in filter to cater 1/1 instead of 01/01
   7: ' - Added logos on Main Menu and Output Report
   8:  
   9: Application.ScreenUpdating = False        ' to disable screen updating while macro is running
  10:  
  11: Dim Path1 As String     ' path of the input/template/report files
  12: Dim Filename1 As String     ' name of the FSHA input file
  13: Dim Filename2 As String     ' name of the FSHB input file
  14: Dim Filename3 As String     ' name of the FMRA input file
  15: Dim Filename4 As String     ' name of the FMRB input file
  16: Dim Filename5 As String     ' name of the output template file
  17: Dim Filename6 As String     ' name of the output report file
  18: Dim Date1 As String     ' date of data to be processed
  19: Dim Date2 As String     ' date for the filter
  20: Dim Date3 As String     ' date for the summary tab
  21: Dim Date4 As String     ' first date of the summary tab
  22: Dim Date5 As String     ' last date of the summary tab
  23: Dim Date6 As String     ' for chart title in summary tab
  24: Dim Date7 As String     ' month of the date for the filter
  25: Dim Date8 As String     ' day of the date for the filter
  26:  
  27: Sheets("Main Menu").Select      ' to read file names and date from main menu tab
  28: Filename1 = Range("C9").Text
  29: Filename2 = Range("C10").Text
  30: Filename3 = Range("C11").Text
  31: Filename4 = Range("C12").Text
  32: Filename5 = Range("C13").Text
  33: Date1 = Range("C15").Text
  34:  
  35: Filename6 = Left(Filename5, 32) + ".xlsx"       ' generating name of report file from template file
  36: Path1 = ThisWorkbook.Path + "\"     ' detecting path of template file
  37:  
  38: If Mid(Date1, 5, 2) < 10 Then       ' to remove the leading 0 of month of the date for the filter
  39:     Date7 = Mid(Date1, 6, 1)
  40: Else
  41:     Date7 = Mid(Date1, 5, 2)
  42: End If
  43:  
  44: If Right(Date1, 2) < 10 Then        ' to remove the leading 0 of day of the date for the filter
  45:     Date8 = Right(Date1, 1)
  46: Else
  47:     Date8 = Right(Date1, 2)
  48: End If
  49:  
  50: Date2 = Date7 + "/" + Date8 + "]"      ' Changing the format of date according to the one used in filter
  51: Date3 = Mid(Date1, 5, 2) + "/" + Right(Date1, 2) + "/" + Left(Date1, 4)     ' Changing the format of date according to the one used in summary tab
  52:  
  53: Windows(Filename5).Activate     ' moving the dates from the summary tab to one day back
  54: Sheets("Summary").Select
  55: Range("C23:E28").Select
  56: Selection.Copy
  57: Range("C22").Select
  58: ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
  59:     IconFileName:=False
  60:  
  61: Sheets(Array("FSHA", "FSHB", "FMRA", "FMRB")).Select        ' to clear previous values of FSHA, FSHB, FMRA, FMRB tabs
  62: Range("A2:J289").Select
  63: Selection.ClearContents
  64:  
  65: '------------------------------------------------------------------------------------------
  66: Workbooks.Open Filename:=Path1 + Filename1      ' open FSHA input file
  67: Columns("A:A").Select       ' select 1st col and apply text to col using tab delimiter
  68: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  69:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
  70:     Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
  71:     :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
  72:     Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
  73: Columns("B:B").Select       ' select 2nd col and add an empty col
  74: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
  75: Range("A1").FormulaR1C1 = "Time"        ' set cell A1 to time
  76: Columns("A:A").Select       ' select 1st col and apply text to col using space delimiter
  77: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  78:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
  79:     Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
  80:     :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
  81: Range("B1").Select      ' select cell B2 and set to date
  82: ActiveCell.FormulaR1C1 = "Date"
  83: Selection.AutoFilter        ' apply filter on cell B2 to filter out Date2
  84: ActiveSheet.Range(Cells(1, 1), Cells(Application.CountA(Range("A:A")), 9)).AutoFilter Field:=2, Criteria1:=Date2
  85: ActiveSheet.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy     ' copy all filtered values
  86: Windows(Filename5).Activate     ' paste to FSHA tab
  87: Sheets("FSHA").Select
  88: Range("A2").Select
  89: ActiveSheet.Paste
  90: Application.CutCopyMode = Flase
  91: Workbooks(Filename1).Close savechanges:=False       ' close FSHA input file without saving the changes
  92:  
  93: '------------------------------------------------------------------------------------------
  94: Workbooks.Open Filename:=Path1 + Filename2      ' open FSHB input file
  95: Columns("A:A").Select       ' select 1st col and apply text to col using tab delimiter
  96: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
  97:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
  98:     Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
  99:     :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
 100:     Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
 101: Columns("B:B").Select       ' select 2nd col and add an empty col
 102: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 103: Range("A1").FormulaR1C1 = "Time"        ' set cell A1 to time
 104: Columns("A:A").Select       ' select 1st col and apply text to col using space delimiter
 105: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 106:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
 107:     Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
 108:     :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
 109: Range("B1").Select      ' select cell B2 and set to date
 110: ActiveCell.FormulaR1C1 = "Date"
 111: Selection.AutoFilter        ' apply filter on cell B2 to filter out Date2
 112: ActiveSheet.Range(Cells(1, 1), Cells(Application.CountA(Range("A:A")), 9)).AutoFilter Field:=2, Criteria1:=Date2
 113: ActiveSheet.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy     ' copy all filtered values
 114: Windows(Filename5).Activate     ' paste to FSHB tab
 115: Sheets("FSHB").Select
 116: Range("A2").Select
 117: ActiveSheet.Paste
 118: Application.CutCopyMode = Flase
 119: Workbooks(Filename2).Close savechanges:=False       ' close FSHB input file without saving the changes
 120:  
 121: '------------------------------------------------------------------------------------------
 122: Workbooks.Open Filename:=Path1 + Filename3      ' open FMRA input file
 123: Columns("A:A").Select       ' select 1st col and apply text to col using tab delimiter
 124: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 125:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
 126:     Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
 127:     :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
 128:     Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
 129: Columns("B:B").Select       ' select 2nd col and add an empty col
 130: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 131: Range("A1").FormulaR1C1 = "Time"        ' set cell A1 to time
 132: Columns("A:A").Select       ' select 1st col and apply text to col using space delimiter
 133: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 134:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
 135:     Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
 136:     :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
 137: Range("B1").Select      ' select cell B2 and set to date
 138: ActiveCell.FormulaR1C1 = "Date"
 139: Selection.AutoFilter        ' apply filter on cell B2 to filter out Date2
 140: ActiveSheet.Range(Cells(1, 1), Cells(Application.CountA(Range("A:A")), 9)).AutoFilter Field:=2, Criteria1:=Date2
 141: ActiveSheet.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy     ' copy all filtered values
 142: Windows(Filename5).Activate     ' paste to FMRA tab
 143: Sheets("FMRA").Select
 144: Range("A2").Select
 145: ActiveSheet.Paste
 146: Application.CutCopyMode = Flase
 147: Workbooks(Filename3).Close savechanges:=False       ' close FMRA input file without saving the changes
 148:     
 149: '------------------------------------------------------------------------------------------
 150: Workbooks.Open Filename:=Path1 + Filename4      ' open FMRB input file
 151: Columns("A:A").Select       ' select 1st col and apply text to col using tab delimiter
 152: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 153:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
 154:     Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
 155:     :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), _
 156:     Array(7, 1), Array(8, 1), Array(9, 1)), TrailingMinusNumbers:=True
 157: Columns("B:B").Select       ' select 2nd col and add an empty col
 158: Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 159: Range("A1").FormulaR1C1 = "Time"        ' set cell A1 to time
 160: Columns("A:A").Select       ' select 1st col and apply text to col using space delimiter
 161: Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
 162:     TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
 163:     Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
 164:     :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
 165: Range("B1").Select      ' select cell B2 and set to date
 166: ActiveCell.FormulaR1C1 = "Date"
 167: Selection.AutoFilter        ' apply filter on cell B2 to filter out Date2
 168: ActiveSheet.Range(Cells(1, 1), Cells(Application.CountA(Range("A:A")), 9)).AutoFilter Field:=2, Criteria1:=Date2
 169: ActiveSheet.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy     ' copy all filtered values
 170: Windows(Filename5).Activate     ' paste to FMRB tab
 171: Sheets("FMRB").Select
 172: Range("A2").Select
 173: ActiveSheet.Paste
 174: Application.CutCopyMode = Flase
 175: Workbooks(Filename4).Close savechanges:=False       ' close FMRB input file without saving the changes
 176:  
 177: '------------------------------------------------------------------------------------------
 178: Windows(Filename5).Activate     ' putting new date in summary tab
 179: Sheets("Summary").Select
 180: Range("C28").FormulaR1C1 = Date3
 181: Date4 = Range("C22").Text       ' generating date for the chart title
 182: Date5 = Range("C28").Text
 183: Date6 = "(" + Left(Date4, (InStr(1, Date4, ",") - 1)) + " - " + Right(Date5, 8) + ")"
 184:  
 185: ActiveSheet.ChartObjects("Chart 1").Activate        ' updating date in chart title
 186: ActiveChart.ChartTitle.Select
 187: ActiveChart.ChartTitle.Text = "MT SMS Transactions" & Chr(13) & Date6
 188: Selection.Format.TextFrame2.TextRange.Characters.Text = _
 189:     "MT SMS Transactions" & Chr(13) & Date6
 190: With Selection.Format.TextFrame2.TextRange.Characters(1, 20).ParagraphFormat
 191:     .TextDirection = msoTextDirectionLeftToRight
 192:     .Alignment = msoAlignCenter
 193: End With
 194: With Selection.Format.TextFrame2.TextRange.Characters(1, 20).Font
 195:     .BaselineOffset = 0
 196:     .Bold = msoTrue
 197:     .NameComplexScript = "+mn-cs"
 198:     .NameFarEast = "+mn-ea"
 199:     .Fill.Visible = msoTrue
 200:     .Fill.ForeColor.RGB = RGB(0, 0, 0)
 201:     .Fill.Transparency = 0
 202:     .Fill.Solid
 203:     .Size = 16
 204:     .Italic = msoFalse
 205:     .Kerning = 12
 206:     .Name = "+mn-lt"
 207:     .UnderlineStyle = msoNoUnderline
 208:     .Strike = msoNoStrike
 209: End With
 210: With Selection.Format.TextFrame2.TextRange.Characters(21, 24).ParagraphFormat
 211:     .TextDirection = msoTextDirectionLeftToRight
 212:     .Alignment = msoAlignCenter
 213: End With
 214: With Selection.Format.TextFrame2.TextRange.Characters(21, 24).Font
 215:     .BaselineOffset = 0
 216:     .Bold = msoTrue
 217:     .NameComplexScript = "+mn-cs"
 218:     .NameFarEast = "+mn-ea"
 219:     .Fill.Visible = msoTrue
 220:     .Fill.ForeColor.RGB = RGB(0, 0, 0)
 221:     .Fill.Transparency = 0
 222:     .Fill.Solid
 223:     .Size = 12
 224:     .Italic = msoFalse
 225:     .Kerning = 12
 226:     .Name = "+mn-lt"
 227:     .UnderlineStyle = msoNoUnderline
 228:     .Strike = msoNoStrike
 229: End With
 230:  
 231: Range("A1").Select      ' selecting first cell in summary tab
 232: Sheets("Main Menu").Select      ' selecting main menu
 233: Range("A1").Select      ' selecting first cell in main menu tab
 234:  
 235: Application.DisplayAlerts = False       ' disabling all notifications
 236: Workbooks.Add.SaveAs Filename:=Path1 + Filename6        ' generating report file
 237: Windows(Filename5).Activate
 238: Sheets("Summary").Copy Before:=Workbooks(Filename6).Sheets(1)       ' copying summary tab from template to report file
 239: Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Select      ' deleting remaining tabs from report file
 240: ActiveWindow.SelectedSheets.Delete
 241: ActiveWorkbook.Save     ' saving report file
 242: Application.DisplayAlerts = True        ' enabling all notifications
 243:  
 244: Application.ScreenUpdating = True     ' to enable screen updating while macro is running
 245: End Sub

References:


if statement


http://www.anthony-vba.kefra.com/vba/vbabasic3.htm#Decision_Structures_-_IF_and_Select_Case


-urShadow

No comments:

Post a Comment