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

BlackBerry. Like never before.

The unshakeable spirit of Mobilink employees!

Spirit of Mobilink employees that remains alive and unshaken. Employee volunteerism remains the key driver in our efforts as our teams continue to deliver relief goods to families in far flung areas. Recent Updates: In Central region, a relief consignment containing 300 hygiene kits, 300 dry food ration packs and 300 NFIs was distributed in Sikhani wala, Mehray Wala and Kotla Androon in the district of Rajanpur by a team of Mobilink Torchbearers from Sales, CC, Security, Fin and IT. Through this exercise, Mobilink reached out to another 600 families.

Let us keep this spirit alive and volunteer our time, energy and expertise to continue making a difference.

http://mobilinkgsm.com

station

Railway Station pe shohar biwi ko lainay gya.

Biwi:
Dekho wo admi kitna khush dikhai day raha hai or tum.

Shohar:
Wo apni Biwi ko chornay aya hai,lainay nahi.


From: Asim Shehzad

From believing to achieving

Hina Qureshi, Navitus
October 25, 2006

Throughout our lives, we all, at one time or another, experience discontent and disappointment. When these feelings go unchecked, our morale slips and our self-confidence takes a nose dive.

It is in times of despair that you need to “Give yourself a break!” Take a step back, identify your flaws, uncover the underlying issues, search for the reasons behind them, and then determine which ones are changeable. Ask yourself this question “Do I want to remain the way I am or do I want to grow and flourish”.

After pondering on the subject of ‘believing to achieving’ I came to the conclusion that things which prevent us from achieving what we want out of life is when we hang on to the past and doubt the future, always expecting the worst possible outcome. You may have come across people who say things like:

· “It didn't work before--why should it work now?”

· “I know I will fail.”

· “Why take a chance--it won't work anyway.”

· “I made a wrong choice.”

· “I wish this wouldn’t have happened.”

People have a difficult time letting go of the past because they are held back by unfinished business. They may regret choices they made or feel guilty about past actions. As long as guilt and regret are not resolved, it is difficult to move forward. Playing safe and hiding from realities that surround you will lead you no where. So stop blaming others, and even your circumstances. Carry your lessons from the past and then close the door on it. Don't dwell on what’s happened indefinitely. Don’t let the past steal your dreams. To move on and live your dreams, clear out the clutter in your mind so that your dreams have room to live and grow. Set goals: Plan, execute and implement them.

Remember! We came to this world with a purpose. Find out what that is. Determine your mission in life and focus on making it happen. There will be challenges along the way. Face them! It is up to you!

You are going to make mistakes. Learn from them rather than get 'run over' by them. It is vital to renew yourself. Learn, unlearn & relearn regularly. You need to be alert of your surroundings, more self-aware, and smart to thrive in today's competitive world. Alvin Toffler, a well known futurologist once said, “The illiterate of the 21st century will not be those who cannot read and write, but those who cannot learn, unlearn and relearn.”

Each one of us is responsible for our own success, career advancement, personal growth and achievement. Take charge of your future. Transform your life! Discover your inner strengths and navigate your way to new horizons by familiarizing yourself with the opportunities and threats in your environment. It’s up to you. It is your future, after all.

So what stops us? It comes down to fear - fear of failure; fear of losing face; fear of being laughed at; fear of the unknown; fear of being hurt. F.E.A.R. is an acronym which stands for False Emotions Appear Real. One of the best ways to counter fear is to DO what you fear. Be careful though. Always fear evil!

A slogan used by a leading multinational company in Pakistan continues to inspire me to this day. It is, “Dare to try, dare to fail, dare to succeed, dare to be different.” This is best exemplified by Michael Jordan, the greatest basketball player of all time, who once said, “I’ve missed more than 9,000 shots in my career. I’ve lost almost 300 games; I have been trusted to take the game winning shot and missed. I’ve failed, over and over and over again in my life. And this is why I succeed.”

http://www.navitus.biz/home/index.php?option=com_content&view=article&id=125:from-believing-to-achieving&catid=34:hina-qureshi&Itemid=201

poison

Man at medical store: "I need poison!"
Chemist: "I can't sell u that until u have prescription."

Man showed his Nikah Nama.

Chemist:
"Oh..! Ok"


From: Bina Aslam

deal

Husband Gifted his wife a Diamond necklace & she didnt talk to him for a month!!
.
.
.
.
.
.

.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.
.

That was the DEAL:D

From: Hasan Wasim

masrufiyat

Insan Dunya Ki Masrufiyat Main Mashghol huta hai
Aur Usse Pata bhi nahi huta K
Jis Kapry Se Us Ka Kafan Ban'na hai

Wo Bazar main Aa Chuka hai

From: Muhammad Madni Shah

Mobilink flood relief contribution crosses Rs. 236 million!

Mobilink’s commitment towards reshaping lives of flood affectees has taken another great leap! Mobilink’s commitment towards flood relief now exceeds Rs. 236 million in addition to contributing thousands of volunteer hours from our dedicated employees. This to date is one of the largest relief initiatives from the private sector. Besides the distribution of healthy food, hygiene kits and essential items, Mobilink has donated prefabricated sheets to the World Health Organization and TDRP worth Rs. 140 million to be used as 270 Health Units across Pakistan.  Recent Updates:  In South region, a relief consignment of 5 trucks carrying 300 hygiene kits, 300 dry food ration packs and 300 Non-Food Items (NFIs) left for Sukkur today. Each set of NFIs for a family includes: 5 quilts, 5 bed sheets, 2 mosquito nets, 1 bucket, chatai, kitchen set, jerry can, etc. These items will be distributed among flood victims tomorrow.  In North region, a relief consignment of 3 trucks carrying 400 hygiene kits and 400 dry food ration packs left for Tank today. Distribution of these items among flood affectees will take place today.  Upcoming:  In North region, 300 NFIs will be sent dispatched for distribution among flood victims of Swat on Saturday.

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

 

In Central region, a relief consignment containing 300 hygiene kits, 300 dry food ration packs and 300 NFIs will also be dispatched on Saturday. Distribution of these relief items among flood affectees will take place over the weekend.

http://mobilinkgsm.com