write at exceltoexplore@gmail.com : Report Automation|Dashboard in Excel| Provide Excel consulting through macro (VBA) automation |Financial Modeling | Ethical Hacking

Monday, 14 May 2012

Excel : Count Number of Cells Colour in Row

Try below code to count the rowwise number of colour cells.
i have hardcode the column value. even comment (A macro comment is a piece of text in a macro which will not be executed by Excel VBA. It is only there to provide you information about the macro)
the lines which provide the last column

the person from this requirement came she used to count the colour rows manually. in actual file there are around 191 columns day wise & rows contain employee names. its hours of work with this code now in fraction of second.





Sub Mtest()
Dim countcolor As Long, ColorCount As Long
Dim i As Long, LC As Long
'LC = Cells(3, Columns.Count).End(xlToLeft).Column
'change row here
For i = 3 To Sheet1.Cells(Rows.Count, "C").End(xlUp).Row
ColorCount = 0
For Each c In Range(Cells(i, 5), Cells(i, 191)) 'change column count here
'For Each c In Range(Cells(i, 5), Cells(i, LC)) 'change column count here
If c.Interior.ColorIndex = 3 Then ColorCount = ColorCount + 1
Next c
countcolor = ColorCount
Cells(i, 191).Offset(0, 2).Value = countcolor
'Cells(i, LC).Offset(0, 1).Value = countcolor
Next i
End Sub


I have taken Red colour in above example .(Interior.ColorIndex = 3)
Excel Color Palette has an index of 56 colors which can be modified using VBA. Each color in the palette is associated with a unique value in the index that can be changed programatically. At times it is useful to know the relative positioning of the various colors within this index as well as how various versions of Excel treat colors


Excel : Unlock Workbook And Unlock Worksheet

If you have forgotten your workbook or worksheet password. You will find below information helpful to unprotect excel workbook or worksheet password

The code below can unlock a workbook password and sheet passwords
Module provides Excel workbook and sheet unlock routines. The algorithm
relies on a backdoor password that can be 1 to 9 characters long where each
character is either an "A" or "B" except the last which can be any character
from ASCII (American Standard Code for Information Interchange) code 32 to 255.Implemented as a regular module for use with any Excel VBA project.

Code by : Kevin M. Jones

Option Explicit
Private Sub DisplayStatus( _
ByVal PasswordsTried As Long _
)
' Display the status in the Excel status bar.
' Syntax
' DisplayStatus(PasswordsTried)
' PasswordsTried - The number of passwords tried thus far.
Static LastStatus As String
LastStatus = Format(PasswordsTried / 57120, "0%") & " of possible passwords tried."
If Application.StatusBar <> LastStatus Then
Application.StatusBar = LastStatus
DoEvents
End If
End Sub
Private Function TrySheetPasswordSize( _
ByVal Size As Long, _
ByRef PasswordsTried As Long, _
ByRef Password As String, _
Optional ByVal Base As String _
) As Boolean
' Try unlocking the sheet with all passwords of the specified size.
' TrySheetPasswordSize(Size, PasswordsTried, Password, [Base])
' Size - The size of the password to try.
' PasswordsTried - The cummulative number of passwords tried thus far.
' Password - The current password.
' Base - The base password from the calling routine.
Dim Index As Long
On Error Resume Next
If IsMissing(Base) Then Base = vbNullString
If Len(Base) < Size - 1 Then
For Index = 65 To 66
If TrySheetPasswordSize(Size, PasswordsTried, Password, Base & Chr(Index)) Then
TrySheetPasswordSize = True
Exit Function
End If
Next Index
ElseIf Len(Base) < Size Then
For Index = 32 To 255
ActiveSheet.Unprotect Base & Chr(Index)
If Not ActiveSheet.ProtectContents Then
TrySheetPasswordSize = True
Password = Base & Chr(Index)
Exit Function
End If
PasswordsTried = PasswordsTried + 1
Next Index
End If
On Error GoTo 0
DisplayStatus PasswordsTried
End Function

 
Private Function TryWorkbookPasswordSize( _
ByVal Size As Long, _
ByRef PasswordsTried As Long, _
ByRef Password As String, _
Optional ByVal Base As String _
) As Boolean
' Try unlocking the workbook with all passwords of the specified size.
' TryWorkbookPasswordSize(Size, PasswordsTried, Password, [Base])
' Size - The size of the password to try.
' PasswordsTried - The cummulative number of passwords tried thus far.
' Password - The current password.
' Base - The base password from the calling routine.
Dim Index As Long
On Error Resume Next
If IsMissing(Base) Then Base = vbNullString
If Len(Base) < Size - 1 Then
For Index = 65 To 66
If TryWorkbookPasswordSize(Size, PasswordsTried, Password, Base & Chr(Index)) Then
TryWorkbookPasswordSize = True
Exit Function
End If
Next Index
ElseIf Len(Base) < Size Then
For Index = 32 To 255
ActiveWorkbook.Unprotect Base & Chr(Index)
If Not ActiveWorkbook.ProtectStructure And Not ActiveWorkbook.ProtectWindows Then
TryWorkbookPasswordSize = True
Password = Base & Chr(Index)
Exit Function
End If
PasswordsTried = PasswordsTried + 1
Next Index
End If
On Error GoTo 0
DisplayStatus PasswordsTried
End Function

 

Public Sub UnlockSheet()

' Unlock the active sheet using a backdoor Excel provides where an alternate

' password is created that is more limited.

Dim PasswordSize As Variant
Dim PasswordsTried As Long
Dim Password As String
PasswordsTried = 0
If Not ActiveSheet.ProtectContents Then
MsgBox "The sheet is already unprotected."
Exit Sub
End If
On Error Resume Next
ActiveSheet.Protect ""
ActiveSheet.Unprotect ""
On Error GoTo 0
If ActiveSheet.ProtectContents Then
For Each PasswordSize In Array(5, 4, 6, 7, 8, 3, 2, 1)
If TrySheetPasswordSize(PasswordSize, PasswordsTried, Password) Then Exit For
Next PasswordSize
End If
If Not ActiveSheet.ProtectContents Then
MsgBox "The sheet " & ActiveSheet.Name & " has been unprotected with password '" & Password & "'."
End If
Application.StatusBar = False
End Sub

 

Public Sub UnlockWorkbook()
' Unlock the active workbook using a backdoor Excel provides where an alternate
' password is created that is more limited.
Dim PasswordSize As Variant
Dim PasswordsTried As Long
Dim Password As String
PasswordsTried = 0
If Not ActiveWorkbook.ProtectStructure And Not ActiveWorkbook.ProtectWindows Then
MsgBox "The workbook is already unprotected."
Exit Sub
End If
On Error Resume Next
ActiveWorkbook.Unprotect vbNullString
On Error GoTo 0
If ActiveWorkbook.ProtectStructure Or ActiveWorkbook.ProtectWindows Then
For Each PasswordSize In Array(5, 4, 6, 7, 8, 3, 2, 1)
If TryWorkbookPasswordSize(PasswordSize, PasswordsTried, Password) Then Exit For
Next PasswordSize
End If
If Not ActiveWorkbook.ProtectStructure And Not ActiveWorkbook.ProtectWindows Then
MsgBox "The workbook " & ActiveWorkbook.Name & " has been unprotected with password '" & Password & "'."
End If
Application.StatusBar = False
End Sub

Saturday, 24 March 2012

Excel : Fill up Blank Rows in a column


If you your columns have blank rows & data. And you want to fill up blank rows with cells having data.
e.g cell A2 contain 1 and cell A10 contain 2. Rows are blank from A3:A9. try below code which will fill up value if cell A2 till cell A9




Sub Mtest()
Dim i As Long
Dim Temp As String

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
If Trim((Cells(i, 1)) = "") Then
Cells(i, 1) = Temp
Else
Temp = Cells(i, 1)
End If
Next
End Sub

Wednesday, 29 February 2012

Excel : Browse Internet in excel worksheet

You can browse or surf internet in excel worksheet......:)

without opening or clicking internet explorer you can surf web pages in excel worksheet.
you can chat on facebook access emails with in excel worksheet.


you can do work in one worksheet & simultaneously browse the web on another worksheet
Steps.
To make the following code work, you'll need to include the "Microsoft Internet Controls" library in your VBA references first.Go to your Visual Basic Editor, Menu Tools -> References select  "Microsoft Internet Controls


  1. click on developer tab
  2. Go to Control->Insert->ActiveX-Control->Click on More Control (Hammer Icon)

      3. you will get More Control window
      4. Select Microsoft Web Browser & Click ok 

    
       5.Go to Control->Insert->ActiveX-Control->Command Button
       6.Right Click on command button
       7.Select View code
       8.copy below code
       9. Exit design mode
Private Sub CommandButton1_Click()
'change you web site url here
WebBrowser1.Navigate "http://www.google.co.in/"
' Wait till the Browser is loaded
Do
DoEvents
Loop Until WebBrowser1.ReadyState = READYSTATE_COMPLETE
End Sub

Thursday, 23 February 2012

Excel : Format Number Lakh Separator

Excel allows only thousand's separator not "lakh" separator
There is difference between Excel Numbering format between Indian & Western system
Both systems agree till 10,000. After that the 'problems' start.

10^5 = Hundred Thousand = 1 Lakh
10^6 = Million = 10 Lakh
10^7 = 10 Million = 100 Lakh = 1 Crore
10^8 = 100 million = 10 Crore
10^9 = 1 Billion = 100 Crore = 1 Arrab
10^10 = 10 Billion = 10 Arrab
10^11 = 100 Billion = 100 Arrab = 1 Kharrab
10^12 = 1 Trillion = 10 Kharrab
In India numerical value for lakh is 100,000 not 100,000 (one hundred thousands)


Here's a useful Excel tip for users in India and other places that use number formats like 100,00,00,000 instead of 1,000,000,000:

With 2 decimals:

[>99999]##\,##\,##0.00;[<-99999.99]-##\,##\,##0.00;##,##0.00

Without decimals:

[>99999]##\,##\,##0;[<-99999.99]-##\,##\,##0;##,##0

For Lakhs and crores (+ve)

[>9999999]##\,##\,##\,##0.00;[>99999]##\,##\,##0.00;##,##0.00

For Lakhs and crores (-ve)

[<-9999999](##\,##\,##\,##0.00);[<-99999](##\,##\,##0.00);##,##0.00

Or

For numbers upto 100 Crores or 1 Arab..

[>9999999]##\,##\,##\,###;[>99999]#\,##\,###;###,###


There is an easier way to change the global settings from Settings > Control Panel > Regional Settings > Numbers, but that will affect all your Excel sheets and the change will be visible only on your system and not on your files which you send to others.


with Vb Code (By : Graham aka parry )


Private Sub Worksheet_Change(ByVal Target As Range)
     '//Written by parry
    Dim c
    If Target.Cells.Count = 1 Then
        Select Case Target.Value
        Case Is >= 1000000000
            Target.Cells.NumberFormat = "##"",""00"",""00"",""00"",""000.00"
        Case Is >= 10000000
            Target.Cells.NumberFormat = "##"",""00"",""00"",""000.00"
        Case Is >= 100000
            Target.Cells.NumberFormat = "##"",""00"",""000.00"
        Case Else
            Target.Cells.NumberFormat = "##,###.00"
        End Select
    Else
        For Each c In Target
            Select Case c.Value
            Case Is >= 1000000000
                c.NumberFormat = "##"",""00"",""00"",""00"",""000.00"
            Case Is >= 10000000
                c.NumberFormat = "##"",""00"",""00"",""000.00"
            Case Is >= 100000
                c.NumberFormat = "##"",""00"",""000.00"
            Case Else
                c.NumberFormat = "##,###.00"
            End Select
        Next c
    End If
End Sub





Excel : Custom Cell Formatting

Right Click on Cell-->Select Format Cells-->Select Custom


"#" is used as a placeholder for permitted digits/Digit placeholder. This code does not display extra zeros.
"?" indicates either a digit/Digit placeholder. This code leaves a space for insignificant zeros but does not display them
, (comma) Thousands separator. A comma followed by a placeholder scales the number by a thousand.

You can design your own custom number formats



Excel : Display Credit Card Number

To Display Credit Card Number in Cell you have to format the cell
if last digit of your credit card number is Zero then you can format cell as 0000 0000 0000 0000
if last digit is not zero than assuming your credit card number is in cell A2 Try below formula
'=LEFT(A2,4)&" "&MID(A2,5,4)&" "&MID(A2,9,4)&" "&RIGHT(A2,4)




Microsoft Excel retains 15 significant digits. To display all 15 digits, you must use a number format (custom or built-in) other than General. The General number format displays up to 11 numeric characters, with the decimal point counting as a numeric character. Therefore, if the number contains a decimal point, Excel can display up to 10 significant digits, but if the number does not contain a decimal point, Excel can display up to 11 significant digits Adding more numbers to the left of the decimal point causes the number to appear in exponential notation.

Tuesday, 21 February 2012

Create Expiry for Excel Workbook

Some times you have to set expiry date for your excel workbook. which will restrict use of workbook after certain period of time.  

  Steps:
  1. Press "Alt+F11" to launch the Visual Basic Editor from Excel
  2. Right-click "ThisWorkbook" in the "Project Explorer" window. Select "View Code" from the list of available options
  3. copy below code
Private Sub Workbook_Open()
'If Sheets("sheet1").Range("a1").Value < Date Then ' you can set value on worksheet
If doe < Date Then 'You can define date as doe
MsgBox "This tool has expired, please contact Admin.", vbCritical, "Expired"
ActiveWorkbook.Close False
End If
End Sub

Sunday, 19 February 2012

MS PowerPoint- Play Video with Timer

This requirement came from my one of my MBA college friend.
show the people that they have never seen\ heard before during presentation
You can play video in Excel and PowerPoint as well.
Many option's are available to get it done. If you use youtube video URL then you require internet connectivity during the presentation. If you use windows media player option you have to save the video on particular drive & carry the video during the presentation.

Best way i found is to convert your video in swf format & insert it in PowerPoint or Excel.
Software Link : http://www.dvdvideosoft.com/products/
download presentation : http://www.mediafire.com/file/n43cez8fic2itrc/Powerpoint-Play Video with Timer.ppt

Steps :

  1. Go to developer tab
  2. On the control group click on insert
  3. Then click on more control (icon like hammer)
  4. You will get More control box ; Select shockwave flash object & click ok
  5. You will get cross sign (+) drag it on Powerpoint slide & select the area for video
  6. Right click on square
  7. Then select properties
  8. Enter the full path to the Shockwave file (SWF) in the Movie property text-box. (e.g "C:\Users\MAHESH\Desktop\Download\abc.swf")
  9. Set the EmbedMovie property to True
  10. Run the slide show

For Countdown timer :




Friday, 17 February 2012

Amazing Excel VBA Creativity

I found below excel workbooks during learning excel VBA
you can download workbook from below links


  • Painting in Excel 
         http://www.mediafire.com/?4aythpdtaj7irkm

       
  • Excel VBA MP3 Player
         http://www.mediafire.com/file/q9hjmticqx0cyc1/Excel VBA-MP3-Player.xls
  • Find Internet Browsing History in Excel sheet
        http://www.mediafire.com/file/bz7q8jf47b57za9/Excel VBA -Find Internet History.xlsb

Monday, 13 February 2012

Greetings in Excel

I have received amazing  response for New year greeting wishes in excel from all who seen them around the world

  • valentine's day greeting cards in Excel
  • happy new year greetings in Excel


Saturday, 11 February 2012

Excel : Find duplicate entry while entering data in column


For any column in worksheet .This will give you alert while entering duplicate entry with msg box & column header name. highlight the duplicate entry


Right click on sheet tab-> view code->copy below code


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Application.WorksheetFunction.CountIf(Range(Cells(2, Target.Column), Cells(Target.Row, Target.Column)), Target) > 1 Then
     Alert = MsgBox(Cells(1, Target.Column) & " Already Exist - Click Yes do delete", vbYesNo)
     If Alert = vbYes Then
     Application.Undo
     Else
     Target.Interior.ColorIndex = 6
     Exit Sub
     End If
End If
End Sub

Excel Find and Highlight Maximum Value from Each Column

this will highlight maximum value from each column in worksheet




Sub Mtest()
Dim c As Range, rng As Range
Dim lCol As Long, LR As Long
With ActiveSheet
    For lCol = 1 To .UsedRange.Columns.Count
      LR = .Cells(.Rows.Count, lCol).End(xlUp).Row
      Set rng = .Range(.Cells(1, lCol), .Cells(LR, lCol))
      For Each c In rng
        If c.Value = Application.WorksheetFunction.Max(rng) Then
          c.Interior.ColorIndex = 3
        Else
          c.Interior.ColorIndex = xlNone
        End If
      Next
    Next lCol
  End With
End Sub

Friday, 10 February 2012

Excel : Open list of website & download data

this requirement came from my friend. He used to open list of websites & download the NAV.
you can download data from web page through web query


Sub Mtest()
Dim page As New InternetExplorer
For i = 2 To Sheets("websitelist").Range("A" & Rows.Count).End(xlUp).Row
URL = Sheets("websitelist").Cells(i, 1)
page.Navigate URL '
page.Visible = True
Do
Loop Until page.ReadyState = READYSTATE_COMPLETE
page.Refresh
'=============================
'call your web query here
'=============================
page.Quit
'if you dont use below line you will get error like
'The remote server machine does not exist or is unavailable
'This quits page and releases the object.
Set page = Nothing
Next i
End Sub

Thursday, 9 February 2012

Excel : Login to Gmail /Yahoomail with Vba


Press Alt + F11
Go to tools->References
select below references & click ok

  • Microsoft Internet Controls
  • Microsoft HTML Object Liabrary


Gmail

Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Sub Login_GMAIL()

Dim oHTML_Element As IHTMLElement
Dim sURL As String
On Error GoTo Err_Clear
sURL = "https://www.gmail.com"
Set oBrowser = New InternetExplorer
oBrowser.Silent = True
oBrowser.timeout = 60
oBrowser.navigate sURL
oBrowser.Visible = True
Do
' Wait till the Browser is loaded
Loop Until oBrowser.readyState = READYSTATE_COMPLETE
Set HTMLDoc = oBrowser.document
HTMLDoc.all.Email.Value = "abc@gmail.com" 'Enter your gmail id here
HTMLDoc.all.passwd.Value = "abc@1234" 'Enter your password here
For Each oHTML_Element In HTMLDoc.getElementsByTagName("input")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next
' oBrowser.Refresh ' Refresh If Needed
Err_Clear:
If Err <> 0 Then
'Debug.Assert Err = 0
Err.Clear
Resume Next
End If
End Sub

'Open login page of Gmail and go to view source you will get below javascript
'<label>
  '<strong class="email-label">Username</strong>
  '<input type="text" spellcheck="false" name="Email" id="Email" value="">
'</label>
'<label>
  '<strong class="passwd-label">Password</strong>
  '<input type="password" name="Passwd" id="Passwd">
'</label>

Yahoomail


Dim HTMLDoc As HTMLDocument
Dim oBrowser As InternetExplorer
Sub Login_YAHOO()

Dim oHTML_Element As IHTMLElement
Dim sURL As String
On Error GoTo Err_Clear
sURL = "https://login.yahoo.com"
Set oBrowser = New InternetExplorer
oBrowser.Silent = True
oBrowser.timeout = 60
oBrowser.navigate sURL
oBrowser.Visible = True
Do
Loop Until oBrowser.readyState = READYSTATE_COMPLETE
Set HTMLDoc = oBrowser.document
HTMLDoc.all.login.Value = "mahesh" 'Enter your yahoo id here
HTMLDoc.all.passwd.Value = "abc" 'Enter your password here
For Each oHTML_Element In HTMLDoc.getElementsByTagName("button")
If oHTML_Element.Type = "submit" Then oHTML_Element.Click: Exit For
Next
Err_Clear:
If Err <> 0 Then
Err.Clear
Resume Next
End If
End Sub
'<label for='username'>Yahoo! ID</label>
'<input name='login' id='username' maxlength='96' tabindex='1' value=''>
'<label for='passwd'>Password</label>
'<input name='passwd' id='passwd' type='password' maxlength='64' tabindex='2'>

Tuesday, 31 January 2012

Excel : Create PDF from excel worksheet

you can use below code  for Excel to PDF conversion


Sub CreatePDF()
    Dim wksSheet As Worksheet
    Dim blnFlag As Boolean
    Dim intI As Integer
    Dim intResult As Byte
 
    intI = 0
    intResult = Application.InputBox("Type 1 for Entire Workbook and Type 0 For Active Worksheets")
    If intResult = 0 Then
    Set wksSheet = ActiveSheet
            wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    ThisWorkbook.Path & "\" & wksSheet.Name, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
                    False
            Exit Sub
    End If
    For Each wksSheet In ThisWorkbook.Worksheets
        If WorksheetFunction.CountA(wksSheet.Cells) <> 0 Then
            If wksSheet.Visible = xlSheetHidden Then
                wksSheet.Visible = xlSheetVisible
                blnFlag = True
            End If
            wksSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                    ThisWorkbook.Path & "\" & wksSheet.Name, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
                    False
                    intI = intI + 1
            If blnFlag = True Then
            wksSheet.Visible = xlSheetHidden
            blnFlag = False
            End If
        End If
    Next
    MsgBox intI & " Worksheet(s) has been Exported to PDF", vbInformation
   End Sub

Saturday, 21 January 2012

Excel : Hack/download Greetings (swf file) from web & Embedding in excel

I found this is best way to wish your friend on any occasion
Most company block certain web sites so even you send them E Greeting card they may not able to view

Hack/download Greetings (swf file ) from http://www.123greetings.com/
1. Go to url http://www.123greetings.com/
2. click on the e card which you want to download

3. Press Ctrl + U or Right click on web page & select view page source
4. Press Ctrl + F & find swf
5. find the url of swf file as shown in below image

4.  Copy the url to new browser window
5.  Press ctrl + S
6. Save the web page. it will save the file in swf ( Shockwave Flash Object ) format
7. Further you can convert this file to any video format using software
  http://www.dvdvideosoft.com/products/
8. You can insert this file in excel as well
 http://excelvbaandmacros.blogspot.com/2011/12/excel-why-this-kolaveri-diembed.html

Wednesday, 11 January 2012

Excel : Delete Blank Rows & Column from worksheet

Try Below :


Sub DeleteBlankRows()
    Dim Rw As Long, RwCnt As Long, Rng As Range
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
On Error GoTo Exits:
   
    If Selection.Rows.Count > 1 Then
        Set Rng = Selection
    Else
        'Set Rng = Range("A1:B6")
     Set Rng = Range(Rows(1), Rows(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row()))
    End If
    RwCnt = 0
    For Rw = Rng.Rows.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(Rng.Rows(Rw).EntireRow) = 0 Then
            Rng.Rows(Rw).EntireRow.Delete
            RwCnt = RwCnt + 1
        End If
    Next Rw
   
Exits:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
End Sub

Sub DeleteBlankColumns()
    Dim Col As Long, ColCnt As Long, Rng As Range
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
On Error GoTo Exits:
   
    If Selection.Columns.Count > 1 Then
        Set Rng = Selection
    Else
    'Set Rng = Range("A1:B6")
        Set Rng = Range(Columns(1), Columns(ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column()))
    End If
    ColCnt = 0
    For Col = Rng.Columns.Count To 1 Step -1
        If Application.WorksheetFunction.CountA(Rng.Columns(Col).EntireColumn) = 0 Then
            Rng.Columns(Col).EntireColumn.Delete
            ColCnt = ColCnt + 1
        End If
    Next Col
   
Exits:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
   
End Sub

Sunday, 8 January 2012

Excel : Export Userform to another workbook

User below code to Export User Form from one workbook to another


Sub Mtest()
    Dim wbSource As Workbook, wbDestination As Workbook
    Set wbSource = Workbooks("Book1")
    Set wbDestination = Workbooks("Book2")
    wbSource.VBProject.VBComponents("Userform1").Export "C:\temp\Userform1.frm"
    wbDestination.VBProject.VBComponents.Import "C:\temp\userform1.frm"

    Kill "C:\temp\userform1.frm"
    Kill "C:\temp\userform1.frx"

End Sub