Delete Blanks in all rows or columns VBA

The following scripts will delete blank cells from rows / columns.

Option Explicit

'DeleteBlankRows will only delete a Row if it's completely empty
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(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


'DeleteBlankColumns will only delete a Column if it's completely empty
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(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

'RemoveRow will delete an entire row IF there is a Blank/empty cell within A Column

Private Sub RemoveRow()

    On Error Resume Next    ' In case there are no blanks

    Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Ping IP Addresses on Worksheet (without disturbing other cells)

I have created a script where i needed to ping IP Addresses on a Worksheet and have not only the results of the ping, but also the mac-address of the end device if possible and all without disturbing (overwriting or deleting) other columns / rows.

It might not be up to the correct standards but it works for me and i wanted to save it here for future reference.

The script can be added to a single module.

'AKA known as QuickPing

Sub WorksheetPing()

Dim MySheet As Worksheet

Dim strColumn

Dim intRow

Dim strComputer

Dim strMACAddress

Dim cell As Range

Dim rNa As Range

Dim FindIt As String

Dim strAddy As String

Dim strColumn1

Set MySheet = Application.ActiveSheet

YesNo = MsgBox("Shall i PING all addresses?", vbYesNo + vbInformation, "PING all addresses on Sheet?")

Select Case YesNo

Case vbYes

On Error GoTo Errormessage

 'Ask which column the IP or Hostname resides

strColumn = InputBox("Which letter column do you want to ping?", "Machines column")

Columns(strColumn).Offset(0, 1).Select

Selection.Insert Shift:=xlToRight

'Replace(ActiveCell.Address(0, 0), ActiveCell.Row, "")

strColumn1 = Replace(ActiveCell.Address(0, 0), ActiveCell.Row, "")

Range("A1").Activate

'Ping the IP Addresses

For intRow = 1 To Cells(65536, strColumn).End(xlUp).Row

Cells(intRow, Asc(UCase(strColumn)) - 63).Value = GetPingInfo(Cells(intRow, strColumn).Value)

Next

Case vbNo

Exit Sub

End Select

YesNo = MsgBox("Do you want the Mac-Addresses?", vbYesNo + vbInformation, "Mac-Addresses can be obtained")

Select Case YesNo

Case vbYes

Application.ScreenUpdating = False

'Change Failures to Red Font and then move them over temporarily

On Error Resume Next

FindIt = "Failure"

Set rNa = ActiveSheet.UsedRange.Find(What:=FindIt, LookIn:=xlValues, LookAt:=xlWhole, _

SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)

If Not rNa Is Nothing Then

strAddy = rNa.Address

Do

rNa.Font.ColorIndex = 3

rNa.Offset(0, -1).Copy

rNa.Offset(0, 0).PasteSpecial xlPasteValuesAndNumberFormats

rNa.Offset(0, -1).clear

Set rNa = ActiveSheet.UsedRange.FindNext(rNa)

Loop While rNa.Address <> strAddy

End If

'Get the Mac-Address

Columns(strColumn).Offset(0, 2).Select

Selection.Insert Shift:=xlToRight

Range("A1").Select

For intRow = 1 To Cells(65536, strColumn).End(xlUp).Row

Cells(intRow, Asc(UCase(strColumn)) - 62).Value = Get_MAC_Address(Cells(intRow, strColumn).Value)

Next

'For Each Cell In Range(Whichever Column was chosen)

   Columns(strColumn1).Select

   For Each cell In Selection

   If cell.Font.ColorIndex = 3 Then

   cell.Copy

   cell.Offset(0, -1).PasteSpecial xlPasteValuesAndNumberFormats

   cell.Value = "Failure"

   cell.Font.ColorIndex = 1

   cell.Offset(1, 0).Activate

   End If

   Next

'Fit all columns

Cells.EntireColumn.AutoFit

Range("A1").Activate

'Deselect the last cell and hide the Display Status Bar

Application.CutCopyMode = False

Application.StatusBar = ""

Application.DisplayStatusBar = False

Application.ScreenUpdating = True

Case vbNo

End Select

Errormessage:

End Sub

Function GetPingInfo(strComputer)

Dim objShell, boolCode

Set objShell = CreateObject("WScript.Shell")

boolCode = objShell.Run("Ping -n 1 -w 300 " & strComputer, 0, True)

   If boolCode = 0 Then

GetPingInfo = "Successful Reply"

Else

GetPingInfo = "Failure"

End If

End Function

Function Get_MAC_Address(strComputer)

Set objShell = CreateObject("WScript.Shell")

Set objFSO = CreateObject("Scripting.FileSystemObject")

On Error Resume Next

objFSO.DeleteFile "c:\MAC.txt", True

On Error GoTo 0

Application.DisplayStatusBar = True

Application.StatusBar = "Getting MAC for " & strComputer & "..."

DoEvents

objShell.Run "cmd /c NBTSTAT -a " & strComputer & " | FIND ""MAC Address"" > C:\MAC.txt", 0, True

Set objMACFile = objFSO.OpenTextFile("C:\MAC.txt", 1, False)

While Not objMACFile.AtEndOfStream

strLine = objMACFile.ReadLine

If Len(strLine) > 35 Then

strMAC = Mid(strLine, 19, 17)

End If

Wend

objMACFile.Close

Set objMACFile = Nothing

Set objShell = Nothing

Set objFSO = Nothing

Get_MAC_Address = strMAC

End Function

Create Table of Contents VBA

This script will create a Table of Contents, documenting every worksheet in the active workbook and putting the results into a table (of contents).

Option Explicit

Sub CreateTOC()

    Dim ws As Worksheet

    Dim nmToc As Name

    Dim rng1 As Range

    Dim lngProceed As Boolean

    Dim bNonWkSht As Boolean

    Dim lngSht As Long

    Dim lngShtNum As Long

    Dim strWScode As String

    Dim vbCodeMod

    'Test for an ActiveWorkbook to summarise

    If ActiveWorkbook Is Nothing Then

        MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"

        Exit Sub

    End If

    'Turn off updates, alerts and events

    With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

        .EnableEvents = False

    End With

    'If the Table of Contents exists (using a marker range name "TOC_Index") prompt the user whether to proceed

    On Error Resume Next

    Set nmToc = ActiveWorkbook.Names("TOC_Index")

    If Not nmToc Is Nothing Then

        lngProceed = MsgBox("Index exists!" & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbCritical, "Warning")

        If lngProceed = vbYes Then

            Exit Sub

        Else

            ActiveWorkbook.Sheets(Range("TOC_Index").Parent.Name).Delete

        End If

    End If

    Set ws = ActiveWorkbook.Sheets.Add

    ws.Move before:=Sheets(1)

    'Add the marker range name

    ActiveWorkbook.Names.Add "TOC_INDEX", ws.[a1]

    ws.Name = "TOC_Index"

    On Error GoTo 0

    On Error GoTo ErrHandler

    For lngSht = 2 To ActiveWorkbook.Sheets.Count

        'set to start at A6 of TOC sheet

        'Test sheets to determine whether they are normal worksheets

        ws.Cells(lngSht + 4, 2).Value = TypeName(ActiveWorkbook.Sheets(lngSht))

        If TypeName(ActiveWorkbook.Sheets(lngSht)) = "Worksheet" Then

            'Add hyperlinks to normal worksheets

            ws.Hyperlinks.Add Anchor:=ws.Cells(lngSht + 4, 1), Address:="", SubAddress:="'" & ActiveWorkbook.Sheets(lngSht).Name & "'!A1", TextToDisplay:=ActiveWorkbook.Sheets(lngSht).Name

        Else

            'Add name of any non-worksheets

            ws.Cells(lngSht + 4, 1).Value = ActiveWorkbook.Sheets(lngSht).Name

            'Colour these sheets yellow

            ws.Cells(lngSht + 4, 1).Interior.Color = vbYellow

            ws.Cells(lngSht + 4, 2).Font.Italic = True

            bNonWkSht = True

        End If

    Next lngSht

    'Add headers and formatting

    With ws

        With .[a1:a4]

            .Value = Application.Transpose(Array(ActiveWorkbook.Name, "", Format(Now(), "dd-mmm-yy hh:mm"), ActiveWorkbook.Sheets.Count - 1 & " sheets"))

            .Font.Size = 14

            .Cells(1).Font.Bold = True

        End With

        With .[a6].Resize(lngSht - 1, 1)

            .Font.Bold = True

            .Font.ColorIndex = 41

            .Resize(1, 2).EntireColumn.HorizontalAlignment = xlLeft

            .Columns("A:B").EntireColumn.AutoFit

        End With

    End With

    'Add warnings and macro code if there are non WorkSheet types present

    If bNonWkSht Then

        With ws.[A5]

            .Value = "This workbook contains at least one Chart or Dialog Sheet. These sheets will only be activated if macros are enabled (NB: Please doubleclick yellow sheet names to select them)"

            .Font.ColorIndex = 3

            .Font.Italic = True

        End With

        strWScode = "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)" & vbCrLf _

                    & "     Dim rng1 As Range" & vbCrLf _

                    & "     Set rng1 = Intersect(Target, Range([a6], Cells(Rows.Count, 1).End(xlUp)))" & vbCrLf _

                    & "     If rng1 Is Nothing Then Exit Sub" & vbCrLf _

                    & "     On Error Resume Next" & vbCrLf _

                    & "     If Target.Cells(1).Offset(0, 1) <> ""Worksheet"" Then Sheets(Target.Value).Activate" & vbCrLf _

                    & "     If Err.Number <> 0 Then MsgBox ""Could not select sheet"" & Target.Value" & vbCrLf _

                    & "End Sub" & vbCrLf

        Set vbCodeMod = ActiveWorkbook.VBProject.VBComponents(ws.CodeName)

        vbCodeMod.CodeModule.AddFromString strWScode

    End If

    'tidy up Application settings

    With Application

        .ScreenUpdating = True

        .DisplayAlerts = True

        .EnableEvents = True

    End With

ErrHandler:

    If Err.Number <> 0 Then MsgBox Err.Description & vbCrLf & "Please note that your Application settings have been reset", vbCritical, "Code Error!"

End Sub

Export Excel Worksheet to Text File

The following code will export a worksheet into a text file.
The script can create a file (and folder if necessary) on the fly.

Create module and paste the following script:


' This exports a sheet or range to a text file, using a
' user-defined separator character.
Public Sub ExportToTextFile(FName As String, _
    Sep As String, SelectionOnly As Boolean, _
    AppendData As Boolean)

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile

If SelectionOnly = True Then
    With Selection
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
Else
    With ActiveSheet.UsedRange
        StartRow = .Cells(1).Row
        StartCol = .Cells(1).Column
        EndRow = .Cells(.Cells.Count).Row
        EndCol = .Cells(.Cells.Count).Column
    End With
End If

If AppendData = True Then
    Open FName For Append Access Write As #FNum
Else
    Open FName For Output Access Write As #FNum
End If

For RowNdx = StartRow To EndRow
    WholeLine = ""
    For ColNdx = StartCol To EndCol
        If Cells(RowNdx, ColNdx).Value = "" Then
            CellValue = Chr(34) & Chr(34)
        Else
           CellValue = Cells(RowNdx, ColNdx).Value
        End If
        WholeLine = WholeLine & CellValue & Sep
    Next ColNdx
    WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
    Print #FNum, WholeLine
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
End Sub

'This is the script you run to get it to work

Sub DoTheExport()
Dim fso
Dim fol As String
'Change location as necessary
fol = "C:\"
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(fol) Then
    fso.CreateFolder (fol)
Else
    MsgBox fol & " already exists!", vbExclamation, "Folder Exists"
End If

'The Export folder needs to match the folder location above.
'The ; in Sep:=";" defines the seperator character. Change this to suit
    ExportToTextFile FName:="C:\Test.txt", Sep:=";", _
       SelectionOnly:=False, AppendData:=True
End Sub

Generate Excel Colour Codes in Hex / RGB

The following code will generate the colours available to you in Excel.

This works in all flavors of Excel i believe (including 2010 although there maybe more colours available to 2010... i don't know)

Paste the following code into a new workbook - ThisWorkbook module

Private Sub Workbook_open()

'57 colors, 0 to 56

  Application.ScreenUpdating = False

  Application.Calculation = xlCalculationManual   'pre XL97 xlManual

Dim i As Long

Dim str0 As String, str As String

For i = 0 To 56

  Cells(i + 1, 1).Interior.ColorIndex = i

  Cells(i + 1, 1).Value = "[Color " & i & "]"

  Cells(i + 1, 2).Font.ColorIndex = i

  Cells(i + 1, 2).Value = "[Color " & i & "]"

  str0 = Right("000000" & Hex(Cells(i + 1, 1).Interior.Color), 6)

  'Excel shows nibbles in reverse order so make it as RGB

  str = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)

  'generating 2 columns in the HTML table

  Cells(i + 1, 3) = "#" & str

  Cells(i + 1, 4).Formula = "=Hex2dec(""" & Right(str0, 2) & """)"

  Cells(i + 1, 5).Formula = "=Hex2dec(""" & Mid(str0, 3, 2) & """)"

  Cells(i + 1, 6).Formula = "=Hex2dec(""" & Left(str0, 2) & """)"

  Cells(i + 1, 7) = "[Color " & i & ")"

Next i

done:

  Application.Calculation = xlCalculationAutomatic  'pre XL97 xlAutomatic

  Application.ScreenUpdating = True

End Sub

You can either run it from the VBA Editor, or save the workbook, close it and open it again.

Put a clock on your User form VBA

The following code will put a clock on a User form. (Works in Office 2007 too)

Create a user form called (frmTimer) with 2 labels side by side and a button on the bottom right. Make one label specialeffect 'Sunken' although this is a personal preference.

Call the labels "lblCurrent" and "lblNow" (minus the quotes)

Call the button "cmdQuit"

Now create 3 modules.

Module 1 - Called "modCallback"

Paste the following code:

Option Explicit

Option Private Module

' Win32 APIs

Private Declare Function GetCurrentVbaProject Lib "vba332.dll" _

    Alias "EbGetExecutingProj" _

   (hProject As Long) As Long

        

Private Declare Function GetFuncID Lib "vba332.dll" _

    Alias "TipGetFunctionId" _

   (ByVal hProject As Long, _

    ByVal strFunctionName As String, _

    ByRef strFunctionID As String) As Long

        

Private Declare Function GetAddr Lib "vba332.dll" _

    Alias "TipGetLpfnOfFunctionId" _

   (ByVal hProject As Long, _

    ByVal strFunctionID As String, _

    ByRef lpfnAddressOf As Long) As Long

 

Public Function AddrOf(CallbackFunctionName As String) As Long

'Address of operator emulator for Office97 VBA

'Authors: Ken Getz and Michael Kaplan

Dim aResult As Long

Dim CurrentVBProject As Long

Dim strFunctionID As String

Dim AddressOfFunction As Long

Dim UnicodeFunctionName As String

    'convert the name of the function to Unicode system

    UnicodeFunctionName = StrConv(CallbackFunctionName, vbUnicode)

    'if the current VBProjects exists...

    If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then

        '...get the function ID of the callback function, based on its

        'unicode-converted name, to ensure that it exists

         aResult = GetFuncID(hProject:=CurrentVBProject, _

                             strFunctionName:=UnicodeFunctionName, _

                             strFunctionID:=strFunctionID)

        'if the function exists indeed ...

        If aResult = 0 Then

            '...get a pointer to the callback function based on

            'the strFunctionID argument of the GetFuncID function

             aResult = GetAddr(hProject:=CurrentVBProject, _

                               strFunctionID:=strFunctionID, _

                               lpfnAddressOf:=AddressOfFunction)

            'if we've got the pointer pass it to the result of the function

            If aResult = 0 Then

                AddrOf = AddressOfFunction

            End If

       End If

   End If

End Function

 

Public Function AddrOf_Callback_Routine() As Long

'Office97 VBE does not recognise the AddressOf operator;

'however, it does not raise a compile-error ...

    AddrOf_Callback_Routine = vbaPass(AddressOf cbkRoutine)

End Function

 

Private Function vbaPass(AddressOfFunction As Long) As Long

    vbaPass = AddressOfFunction

End Function

Module 2 - Called "modClock"

Paste the following code:

Option Explicit

Option Private Module

' Public Properties

Public mClockView As String

Public mCountdown  As Long

Public mTimer24 As Range

Public mTimerStart As Range

Public mTimerSecs As Range

Public mStartTime As Double

Public mStopTime As Double

Public mStopTotal As Double

'Private Properties

Private WindowsTimer As Long

Public Sub StartTimer()

    mStartTime = Now

    frmTimer.Show

    

    'reset total stoppage time counter

    mStopTotal = 0

    fncWindowsTimer 1000, WindowsTimer        '1 sec

End Sub

Public Sub StopTimer()

    'save time clock stopped for later

    mStopTime = Now

    fncStopWindowsTimer 

End Sub

Public Sub RestartTimer()

    'add stoppage time to total stoppage time

    mStopTotal = mStopTotal + Now - mStopTime

    fncWindowsTimer 1000, WindowsTimer        '1 sec

End Sub

Module 3 - Called "modShared"

Paste the following code:

Option Explicit

Option Private Module

' Application Constants

Public Const AppId As String = "xldTimer"

Public Const AppTitle As String = "xld Timer Add-In"

Public Const AppHead As String = "xld Timer"

Public Const AppMenu As String = "xld Ti&mer"

Public nTimeEnd As Double

' Win32 APIs

Private Declare Function FindWindow Lib "user32" _

    Alias "FindWindowA" _

   (ByVal lpClassName As String, _

    ByVal lpWindowName As String) As Long

Private Declare Function SetTimer Lib "user32" _

   (ByVal hWnd As Long, _

    ByVal nIDEvent As Long, _

    ByVal uElapse As Long, _

    ByVal lpTimerFunc As Long) As Long

        

Private Declare Function KillTimer Lib "user32" _

   (ByVal hWnd As Long, _

    ByVal nIDEvent As Long) As Long

Public Function cbkRoutine(ByVal Window_hWnd As Long, _

                           ByVal WindowsMessage As Long, _

                           ByVal EventID As Long, _

                           ByVal SystemTime As Long) As Long

Dim CurrentTime As String

    On Error Resume Next

    UpdateForm

End Function

Public Function fncStopWindowsTimer()

    KillTimer hWnd:=FindWindow("XLMAIN", Application.Caption), _

              nIDEvent:=0 'WindowsTimer

End Function

Public Function fncWindowsTimer(TimeInterval As Long, _

                                WindowsTimer As Long) As Boolean

    WindowsTimer = 0

    'if Excel2000 or above use the built-in AddressOf operator to

    'get a pointer to the callback function

    If Val(Application.Version) > 8 Then

        WindowsTimer = SetTimer(hWnd:=FindWindow("XLMAIN", Application.Caption), _

                                nIDEvent:=0, _

                                uElapse:=TimeInterval, _

                                lpTimerFunc:=AddrOf_Callback_Routine)

    Else 'use K.Getz & M.Kaplan function to get a pointer

        WindowsTimer = SetTimer(hWnd:=FindWindow("XLMAIN", Application.Caption), _

                                nIDEvent:=0, _

                                uElapse:=TimeInterval, _

                                lpTimerFunc:=AddrOf("cbkRoutine"))

    End If

    

    fncWindowsTimer = CBool(WindowsTimer)

    DoEvents

End Function

Public Function UpdateForm()

Dim nNow As Double

Dim nLeft As Double

    

    nNow = Now

    With frmTimer

            .lblNow = Format(Date, "dd mmm yyyy") & " " & _

                      Format(nNow, "hh:mm:ss")

    End With

End Function

Call ShowTimer to launch the form

Sub ShowTimer()

    frmTimer.Show

End Sub

Clearing blank results from a Listbox using VBA

In this example, i have a Userform with a Listbox (Listbox1) and a Button (CommandButton1).

When a Listbox is populated, you might want to remove empty entries with the click of a button. The following code will remove those entries.

Create a User form as per above. 1 List box called Listbox1 and a Button called CommandButton1.

Within the User form, paste the following code.

Option Explicit

'This button will remove the blank entries.

Private Sub CommandButton1_Click()

  Dim l As MSForms.ListBox: Set l = Me.ListBox1

  Dim i As Long: i = 0

  '' remove anything that looks like a blank

  While i < l.ListCount

    If "" = Trim$(l.List(i, 0)) Then: l.RemoveItem (i): Else i = 1 + i

  Wend

End Sub

'For demonstration purposes, when the Userform is activated it will populate the

'Userform with 8 items along with blank entries.

Private Sub UserForm_Activate()

  ' locals

  Dim l As MSForms.ListBox: Set l = Me.ListBox1

  Dim i As Long: i = 0

  ' stick items in the list box

  For i = 1 To 8

    Call l.AddItem("Item : " & CStr(i))

    Call l.AddItem("    ")

  Next i

End Sub

Changing Screen Resolution using VBA

Although the end user might not thank you for it, it's possible to inform the end user that their screen resolution isn't suitable. Perhaps you have a particularly large Userform that requires a certain screen resolution to fit and anything less wouldn't be acceptable.

Whatever the reason, this code will determine the current Screen resolution and then inform the user that the resolution is wrong and ask them if they would like to change the resolution automatically.

Source Code: VBA Express. http://www.vbaexpress.com/kb/getarticle.php?kb_id=32

Paste the following code into a Module.

Option Explicit

 

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0

Const SM_CYSCREEN = 1

 

Sub VerifyScreenResolution(Optional Dummy As Integer)

    Dim x  As Long

    Dim y  As Long

    Dim MyMessage As String

    Dim MyResponse As VbMsgBoxResult

     

    x = GetSystemMetrics(SM_CXSCREEN)

    y = GetSystemMetrics(SM_CYSCREEN)

    If x = 1024 And y = 768 Then

    Else

        MyMessage = "Your current screen resolution is " & x & " X " & y & vbCrLf & "This program " & _

        "was designed to run with a screen resolution of 1024 X 768 and may not function properly " & _

        "with your current settings." & vbCrLf & "Would you like to change your screen resolution?"

        MyResponse = MsgBox(MyMessage, vbExclamation + vbYesNo, "Screen Resolution")

    End If

    If MyResponse = vbYes Then

        Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3")

    End If

End Sub

Pull Worksheet information into Userform

The following code is used on a Userform.

It is used for pulling in information from a Worksheet into a Userform.
For this instance, the workbook will be open, but i don't see why you couldn't reference a closed workbook (by opening it temporarily....)

Firstly, design a userform that looks like this:

 What we have here on the form is:

10 textboxes called TextBox1 through to TextBox10.
1 Listbox called ListBox1
3 Buttons. 
CommandButton1 (top left)
CommandButton2 (bottom left)
CommandButton3 (bottom right)


Once that has been completed, add the following code to the Userform.


Option Explicit
Private Sub CommandButton1_Click()
'Load the ListBox
Dim myRng As Range
Dim cw As Variant
Dim c As Single

With Sheets("Sheet1")
Set myRng = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("A" & Sheets("Sheet1").Rows.Count).End(xlUp).Offset(, 9))
End With
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
TextBox7.Value = ""
TextBox8.Value = ""
TextBox9.Value = ""
TextBox10.Value = ""

With Me.ListBox1
    .ColumnCount = 10
    .RowSource = myRng.Address(external:=True)
        cw = ""
        For c = 1 To .ColumnCount
        cw = cw & myRng.Columns(c).Width & ";"
        Next c
     .ColumnWidths = cw
     .ListIndex = -1
End With
End Sub


Private Sub CommandButton2_Click()
'Change selection
With ListBox1
If (.Value <> vbNullString) Then
 Range(.RowSource)(.ListIndex + 1, 1).Value = UserForm1.TextBox1.Value
 Range(.RowSource)(.ListIndex + 1, 2).Value = UserForm1.TextBox2.Value
 Range(.RowSource)(.ListIndex + 1, 3).Value = UserForm1.TextBox3.Value
 Range(.RowSource)(.ListIndex + 1, 4).Value = UserForm1.TextBox4.Value
 Range(.RowSource)(.ListIndex + 1, 5).Value = UserForm1.TextBox5.Value
 Range(.RowSource)(.ListIndex + 1, 6).Value = UserForm1.TextBox6.Value
 Range(.RowSource)(.ListIndex + 1, 7).Value = UserForm1.TextBox7.Value
 Range(.RowSource)(.ListIndex + 1, 8).Value = UserForm1.TextBox8.Value
 Range(.RowSource)(.ListIndex + 1, 9).Value = UserForm1.TextBox9.Value
 Range(.RowSource)(.ListIndex + 1, 10).Value = UserForm1.TextBox10.Value
Else
 MsgBox "Please enter data"
End If
End With
End Sub

Private Sub CommandButton3_Click()
Unload Me
End Sub

Private Sub ListBox1_Change()
Dim I
On Error GoTo FTB   '<---- When there are <10 columns
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
TextBox5.Value = ""
TextBox6.Value = ""
TextBox7.Value = ""
TextBox8.Value = ""
TextBox9.Value = ""
TextBox10.Value = ""
FTB:

On Error GoTo ES   '<---- When there are <10 columns
TextBox1.Value = ListBox1.Column(0)
TextBox2.Value = ListBox1.Column(1)
TextBox3.Value = ListBox1.Column(2)
TextBox4.Value = ListBox1.Column(3)
TextBox5.Value = ListBox1.Column(4)
TextBox6.Value = ListBox1.Column(5)
TextBox7.Value = ListBox1.Column(6)
TextBox8.Value = ListBox1.Column(7)
TextBox9.Value = ListBox1.Column(8)
TextBox10.Value = ListBox1.Column(9)
ES:
End Sub

Create a new module and paste the following code. This will launch the Userform.

Sub GetIt()

UserForm1.Show

End Sub

Building & Customization of menu's in Excel.

The following code has come from Microsoft and i have found it invaluable when it came to building new menu's or altering menu's i have built using the Ozgrid Custom Menu i posted in another blog.


'Return an ID for a command bar control
'The following example code returns the ID for the active menu bar:
Sub Id_Control()
Dim myId As Object
   Set myId = CommandBars("Worksheet Menu Bar").Controls("File")
   MsgBox myId.Caption & Chr(13) & myId.ID
End Sub

'Determine the name of the active menu bar
'The following example code returns the name for the active menu bar:
Sub MenuBars_GetName()
   MsgBox CommandBars.ActiveMenuBar.Name
End Sub


'Save the active state (for built-in or for customized menu bars)
'You may want to declare the OriginalMenuBar variable a public variable so that
'a subroutine can use it in another subroutine, such as an Auto_Close subroutine.
'Declaring and using the variable this way resets the user's previous menu bar to its original state.
'The following sample macro resets the menu bar:
Public OriginalMenuBar As Object
Sub MenuBars_Capture()
   Set OriginalMenuBar = CommandBars.ActiveMenuBar
End Sub

'Display a custom command bar
'The following example creates and displays a custom My Custom Bar menu bar,
'and then replaces the built-in menu bar:
Sub MenuBar_Show()
Dim myNewBar As Object
   Set myNewBar = CommandBars.Add(Name:="Custom1", Position:=msoBarFloating)
   ' You must first enable your custom menu bar before you make it visible.
   ' Enabling a menu bar adds it to the list of available menu bars on
   ' the Customize dialog box.
' Setting the menubar property to True replaces the built-in menu bar.
   myNewBar.Enabled = True
   myNewBar.Visible = True
End Sub

'Delete a custom command bar
'The following example code deletes the custom menu bar that is named Custom 1:
Sub MenuBar_Delete()
   CommandBars("Custom1").Delete
End Sub

'Hide a command bar
'The following example code removes the built-in Chart menu bar from the
'list of available menu bars:
Sub MenuBar_Disabled()
   CommandBars("Chart").Enabled = False
End Sub

'Display a command bar
'The following example code adds the built-in Chart menu bar from the
'list of available menu bars:
Sub MenuBar_Enabled()
   CommandBars("Chart").Enabled = True
End Sub

'Restore a built-in command bar
'Restoring a menu bar resets the default controls (for both menus and menu items).
'The following example code restores the built-in Chart menu bar:
Sub MenuBar_Restore()
   CommandBars("Chart").Reset
End Sub

'Note You can only reset built-in menu bars. You cannot reset a custom menu bar.

'Add a custom menu control to a command bar
'The following example code adds the name of a menu that you add programmatically to the Worksheet menu bar. 
'For example, this code adds the menu name New Menu to the to the Worksheet menu bar.

'Note You can give this menu any name that you want.

Sub Menu_Create()
Dim myMnu As Object
   Set myMnu = CommandBars("Worksheet menu bar").Controls. _
      Add(Type:=msoControlPopup, before:=3)
   With myMnu
   ' The "&" denotes a shortcut key assignment (Alt+M in this case).
      .Caption = "New &Menu"
   End With
End Sub

'Disable a menu control on a command bar
'A menu control that is disabled appears dimmed and is not available on a command bar.
'The following example disables the New Menu menu:
Sub Menu_Disable()
   CommandBars("Worksheet menu bar").Controls("New &Menu").Enabled = False
End Sub

'Enable a menu control on a command bar
'The following example code enables the New Menu menu that you disabled in the "Disable
'a menu control on a command bar" section:
Sub Menu_Enable()
   CommandBars("Worksheet menu bar").Controls("New &Menu").Enabled = True
End Sub

'Delete a menu control on a command bar
'The following code example deletes the New Menu menu that you created in the "Add a
'custom menu control to a command bar" section from the Worksheet menu bar:
Sub Menu_Delete()
   CommandBars("Worksheet menu bar").Controls("New &Menu").Delete
End Sub

'Restore a menu control on a command bar
'The following example code restores the built-in Chart menu bar on the Worksheet menu bar:
Sub Menu_Restore()
Dim myMnu As Object
   Set myMnu = CommandBars("Chart")
   myMnu.Reset
End Sub


'Add a separator bar to a menu control
'The following example code adds a separator bar before the Worksheet command on the
'Insert Menu:
Sub menuItem_AddSeparator()
   CommandBars("Worksheet menu bar").Controls("Insert") _
   .Controls("Worksheet").BeginGroup = True
End Sub

'Note To remove a separator bar, set the BeginGroup property to False.
'Create a custom command control on a menu
'The following example code creates a new command that is named Custom1 on the Tools menu
'of the Worksheet menu bar, and then runs the Code_Custom1 macro when you click Custom1:
Sub menuItem_Create()
   With CommandBars("Worksheet menu bar").Controls("Tools")
      .Controls.Add(Type:=msoControlButton, before:=1).Caption = "Custom1"
      .Controls("Custom1").OnAction = "Code_Custom1"
   End With
End Sub

'Put a check mark next to a command control
'The following example code puts a check mark next to the Custom1 command if it is not
'selected, and then removes the check mark if the Custom1 command is selected:
Sub menuItem_checkMark()
Dim myPopup As Object

   Set myPopup = CommandBars("Worksheet menu bar").Controls("Tools")
   If myPopup.Controls("Custom1").State = msoButtonDown Then
      ' Remove check mark next to menu item.
      myPopup.Controls("Custom1").State = msoButtonUp
      MsgBox "Custom1 is now unchecked"
      Else
        ' Add check mark next to menu item.
         myPopup.Controls("Custom1").State = msoButtonDown
         MsgBox "Custom1 is now checked"
    End If
End Sub

'Disable a command control on a command bar
'The following example code disables the Custom1 command that you created on the Tools
'menu in the "Create a custom command control on a menu" section:
Sub MenuItem_Disable()
Dim myCmd As Object
   Set myCmd = CommandBars("Worksheet menu bar").Controls("Tools")
   myCmd.Controls("Custom1").Enabled = False
End Sub

'Enable a command control on a command bar
'The following example code enables the Custom1 command that you disabled in the
'"Disable a command control on a command bar" section:
Sub MenuItem_Enable()
Dim myCmd As Object
   Set myCmd = CommandBars("Worksheet menu bar").Controls("Tools")
   myCmd.Controls("Custom1").Enabled = True
End Sub

'Delete a command control on a menu
'The following example code deletes the Save command on the File menu:
Sub menuItem_Delete()
Dim myCmd As Object
   Set myCmd = CommandBars("Worksheet menu bar").Controls("File")
   myCmd.Controls("Save").Delete
End Sub

'Restore a built-in command control on a menu
'To restore a command control on a menu, you must know the identification (ID) number
'for the control. To determine the ID number, see the "Return an ID for a command bar
'Control " section. The following example deletes and then restores the Save command that "
'you deleted in the "Delete a command control on a menu" section:
Sub menuItem_Restore()
Dim myCmd As Object
   Set myCmd = CommandBars("Worksheet menu bar").Controls("File")
   ' Id 3 refers to the Save menu item control.
   myCmd.Controls.Add Type:=msoControlButton, ID:=3, before:=5
End Sub

'Add a submenu
'The following example code adds a new submenu that is named NewSub to the Tools menu
'on the Worksheet menu bar:
Sub SubMenu_Create()
Dim newSub As Object
   Set newSub = CommandBars("Worksheet menu bar").Controls("Tools")
   With newSub
      .Controls.Add(Type:=msoControlPopup, before:=1).Caption = "NewSub"
   End With
End Sub

'Add a command to a submenu
'The following example code adds a new command that is named SubItem1 to the NewSub
'submenu, and then it runs the Code_SubItem1 macro when you click SubItem1:
Sub SubMenu_AddItem()
Dim newSubItem As Object
   Set newSubItem = CommandBars("Worksheet menu bar") _
   .Controls("Tools").Controls("NewSub")
   With newSubItem
      .Controls.Add(Type:=msoControlButton, before:=1).Caption = "SubItem1"
      .Controls("SubItem1").OnAction = "Code_SubItem1"
   End With
End Sub

'Disable a command control on a submenu
'The following example code disables the same SubItem command that you created in the
'"Add a command to a submenu" section :
Sub SubMenu_DisableItem()
   CommandBars("Worksheet menu bar").Controls("Tools") _
   .Controls("NewSub").Controls("SubItem1").Enabled = False
End Sub


'The following example enables the same SubItem command:
Sub SubMenu_EnableItem()
   CommandBars("Worksheet menu bar").Controls("Tools") _
   .Controls("NewSub").Controls("SubItem1").Enabled = True
End Sub

'Delete a command on a submenu
'The following example deletes the SubItem1 command that you created on the NewSub
'submenu in the "Add a command to a submenu" section:
Sub SubMenu_DeleteItem()
   CommandBars("Worksheet menu bar").Controls("Tools") _
   .Controls("NewSub").Controls("SubItem1").Delete
End Sub

'Disable a submenu control
'The following example code disables the NewSub submenu that you created on the Tools
'menu in the "Add a submenu" section:
Sub SubMenu_DisableSub()
   CommandBars("Worksheet menu bar").Controls("Tools") _
   .Controls("NewSub").Enabled = False
End Sub

'Note To enable the disabled control, set the Enabled property to True.
'Delete a submenu control
'The following example code deletes the NewSub submenu that you created on the Tools
'menu in the "Add a submenu" section:
Sub SubMenu_DeleteSub()
   CommandBars("Worksheet menu bar").Controls("Tools") _
   .Controls("NewSub").Delete
End Sub


'Create a new shortcut menu bar
'The following example code creates a new shortcut menu bar that is named myShortcutBar:
Sub Shortcut_Create()
Dim myShtCtBar As Object
   Set myShtCtBar = CommandBars.Add(Name:="myShortcutBar", _
   Position:=msoBarPopup)
'   ‘ This displays the shortcut menu bar.
'   ‘ 200, 200 refers to the screen position in pixels as x and y coordinates.
   myShtCtBar.ShowPopup 200, 200
End Sub

'Note The shortcut menu bar appears empty because no controls (menu items or submenus)
'have been added to it.



'Create a command on a shortcut menu bar
'The following example code creates a new menu command that is named Item1 on the
'myShortcutBar shortcut menu bar and it runs the Code_Item1 macro when you click Item1:
Sub Shortcut_AddItem()
Dim myBar As Object
   Set myBar = CommandBars("myShortcutBar")
   With myBar
      .Controls.Add(Type:=msoControlButton, before:=1).Caption = "Item1"
      .Controls("Item1").OnAction = "Code_Item1"
   End With
   myBar.ShowPopup 200, 200
End Sub

'Disable a command control on a shortcut menu bar
'The following example code disables the Item1 command that you created in the
'"Create a command on a shortcut menu" section:
Sub Shortcut_DisableItem()
   Set myBar = CommandBars("myShortcutBar")
   myBar.Controls("Item1").Enabled = False
   myBar.ShowPopup 200, 200
End Sub

'Note To enable the disabled item, set the Enabled property to True.
'Delete a command on a shortcut menu bar
'The following example code deletes the menu command that is named Item1 on the
'myShortcutBar shortcut menu bar:
Sub Shortcut_DeleteItem()
   Set myBar = CommandBars("myShortcutBar")
   myBar.Controls("Item1").Delete
   myBar.ShowPopup 200, 200
End Sub

'Delete a shortcut menu bar
'Deleting the shortcut menu bar removes all the items. You cannot restore a deleted
'custom menu bar. To restore it, you must re-create it and all the menu items and
'the submenus.
'The following example code deletes the myShortCutBar shortcut menu bar that you created in the "Create a command on a shortcut menu bar" section:
Sub Shortcut_DeleteShortCutBar()
   CommandBars("MyShortCutBar").Delete
End Sub

'Restore a command on a built-in shortcut menu bar
'The following example code restores the default commands on the worksheet Cell
'shortcut menu bar:
Sub Shortcut_RestoreItem()
   CommandBars("Cell").Reset
End Sub


'Submenus on shortcut menus
'You can create submenus on shortcut menu bars. Submenus appear to the side of the
'parent menu when you click a command control. A command that is a submenu control
'has a small, black arrow that is located to the right of its name.
'Create a new submenu on a shortcut menu bar
'The following example adds a new submenu that is named NewSub on the worksheet
'Cell shortcut menu:
Sub ShortcutSub_Create()
   CommandBars("Cell").Controls.Add(Type:=msoControlPopup, before:=1) _
   .Caption = "NewSub"
    ' This displays the shortcut menu bar.
    ' 200, 200 refers to the screen position in pixels as x and y coordinates.
   CommandBars("Cell").ShowPopup 200, 200
End Sub

'Note The submenu is empty because no menu items have been added to it.
'Create a command control on a submenu that is located on a shortcut menu bar
'The following macro adds the SubItem1 command to the submenu NewSub that you
'created on the Cell shortcut menu, and then runs the Code_SubItem1 macro when you
'Click SubItem1:
Sub ShortcutSub_AddItem()
Dim newSubItem As Object
Set newSubItem = CommandBars("Cell").Controls("NewSub")
   With newSubItem
      .Controls.Add(Type:=msoControlButton, before:=1).Caption = "subItem1"
      ' This will run the subItem1_Code macro when subItem1 is clicked.
      .Controls("subItem1").OnAction = "Code_subItem1"
   End With
   ' This displays the Cell shortcut menu bar.
   ' 200, 200 refers to the screen position in pixels as x and y coordinates
   CommandBars("Cell").ShowPopup 200, 200
End Sub

'Disable a submenu item control on a shortcut menu
'The following example code disables the SubItem1 command on the NewSub submenu:
Sub ShortcutSub_DisableItem()
   CommandBars("Cell").Controls("NewSub") _
   .Controls("subItem1").Enabled = False
   ' This displays the Cell shortcut menu bar.
   ' 200, 200 refers to the screen position in pixels as x and y coordinates.
   CommandBars("Cell").ShowPopup 200, 200
End Sub

'Note To enable a disabled item, set the Enabled property to True.
'Delete a submenu item control on a shortcut menu
'The following example deletes the SubItem1 command on the NewSub submenu:
Sub ShortcutSub_DeleteItem()
   CommandBars("Cell").Controls("NewSub").Controls("subItem1").Delete
   ' This displays the Cell shortcut menu bar.
   ' 200, 200 refers to the screen position in pixels as x and y coordinates.
   CommandBars("Cell").ShowPopup 200, 200
End Sub

'Disable a submenu control on a shortcut menu
'The following example code disables the NewSub submenu on the Cell shortcut menu bar:
Sub ShortcutSub_DisableSub()
   CommandBars("Cell").Controls("NewSub").Enabled = False
   ' This displays the Cell shortcut menu bar.
   ' 200, 200 refers to the screen position in pixels as x and y coordinates.
   CommandBars("Cell").ShowPopup 200, 200
End Sub

'Note To enable a disabled item, set the Enabled property to True.
'Delete a submenu control on a shortcut menu
'The following example code deletes the NewSub submenu that you created on the
'Cell shortcut menu bar:
Sub ShortcutSub_DeleteSub()
   CommandBars("Cell").Controls("NewSub").Delete
   ' This displays the Cell shortcut menu bar.
   ' 200, 200 refers to the screen position in pixels as x and y coordinates.
   CommandBars("Cell").ShowPopup 200, 200
End Sub