Wednesday, September 29, 2010

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.

Post Type :

Youve_Never_Seen_BlackBerry®_Like_This

The unshakeable spirit of Mobilink employees!

Post Type :

clip_image001clip_image002clip_image003

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

Tuesday, September 28, 2010

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

Monday, September 27, 2010

deal

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

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

That was the DEAL:D

From: Hasan Wasim

Saturday, September 25, 2010

masrufiyat

Post Type :
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

Friday, September 24, 2010

Mobilink flood relief contribution crosses Rs. 236 million!

Post Type :

Mobilink’s commitment towards reshaping lives of flood affectees has taken another great leap! Mobilink’s commitment towards flood relief now

clip_image001

clip_image002clip_image004

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


Related Posts Plugin for WordPress, Blogger...