davesexcel.com

Excel information

VBA Examples

Find a Value in Column A using a loop

Loop through Range

 

Loop Through a Range

 

 

 Home

 

Loop Through Sheets and get Value from a range

Loop through Range

 

 

 

Get a value from a formula in each sheet

Loop through Range

 

 

 

Loop through sheets and filter

Loop through Range

 

 

 

 

Home

Find Values Delete Rows

Loop through Range

 

 

 

Home

Copy and Paste Codes

Copy and Paste examples using VBA

Untitled 2

 

 

Home

 

 

Controls VBA Examples

Populate Combox No Duplicates

Home

 

 

 

Sum Between Blanks or text, Copy just text, Select non-blank cells

Untitled 2

Ways to use special cells

If you used the macro recorder to select special cells you would do this....
Start the recorder
select Column A
hit F5 key on the key board
Click the "Special" button
Click the options for the type of cells you want to select.

This is an example of using special cells with the macro recorder,
it will select non-blank cells in Column A and paste them to cell F1

This is how that same code would look using VBA, same result, cleaner code and cells are not selected.

Select just Non-Blank Cells

Select just Text

Copy and Paste just Numbers

 Copy and past just text

Sum all numbers in column A and place result in B1

Sum each group of numbers in Column A and place in column B

 

Check Out the example

 

Special Cells

Get Unique Items

Here is a nice little code that will extract the Unique Items from Column A and Place them in Column B. The downside is that it will only extract text items. Numbers will be ignored.

 

Sub GetuniqueItems()

    Dim Rws As Long, Rng As Range, c

    Dim Col As New Collection, Ar(), x

    Rws = Cells(Rows.Count, "A").End(xlUp).Row

    Set Rng = Range(Cells(2, 1), Cells(Rws, 1))

    On Error Resume Next

    For Each c In Rng.Cells

        Col.Add c.Value, c.Value

    Next c

    On Error GoTo 0

    ReDim Ar(1 To Col.Count)

    For x = 1 To Col.Count

        Ar(x) = Col(x)

    Next x

    Range("B1").Resize(Col.Count, 1).Value = WorksheetFunction.Transpose(Ar)

End Sub

 When adding an item to a collection, there can be no duplicates that is the reason for the "On error resume next".

 Home

 

Delete Row when Criteria is met

Here are some example codes to delete rows that have the letter "a" in column A

Sub Reset()

    Range("K1:M1").ClearContents

    Sheets("Sheet2").Columns("A:A").Copy Sheets("Sheet1").Range("A1")

End Sub

Sub DeleteRwsWithAutoFilter()

'by Dave Morrison

    Application.ScreenUpdating = False

    Range("A1").AutoFilter Field:=1, Criteria1:="a"

    Range("A1").CurrentRegion.Offset(1, 0). _

SpecialCells(xlCellTypeVisible).EntireRow.Delete

    Range("A1").AutoFilter

End Sub

Sub DeleteRowsWith_a()

'by Dave Morrison

'This is the slowest method

    Dim fRng As Range

    Dim NewRng As Range, c As Object

    Dim Rws As Long, Rng As Range

    Application.ScreenUpdating = False

    Rws = Cells(Rows.Count, "A").End(xlUp).Row

    Set Rng = Range(Cells(2, 1), Cells(Rws, 1))

    For Each c In Rng.Cells

        If c = "a" Then

            If NewRng Is Nothing Then

                Set NewRng = c

            Else

                Set NewRng = Union(NewRng, c)

            End If

        End If

    Next c

    If NewRng Is Nothing Then

        MsgBox "No rows to delete"

    Else

        NewRng.EntireRow.Delete

    End If

End Sub

Sub DeleteRowsReverseLoop()

    Application.ScreenUpdating = False

    Dim lastrow As Long, r As Long

    lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    For r = lastrow To 1 Step -1

        If Cells(r, 1).Value = "a" Then Rows(r).Delete

    Next r

End Sub

Sub DeleteRowsWithFind()

'' DeleteRowsWithFind Macro

' by Dave Morrison

    Dim Rws As Long, Rng As Range

    Application.ScreenUpdating = False

    Rws = Cells(Rows.Count, "A").End(xlUp).Row

    Set Rng = Range(Cells(2, 1), Cells(Rws, 1))

    On Error Resume Next

    With Rng

        .Replace "a", "", xlWhole

        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    End With

End Sub

Download the attachment,  click the button to reset column A with data, then select the option code to run to see which one is the fastest. It records the start and stop time of the macro as well.

The sample workbook uses a range of 10,000 rows to go through and deletes the rows that have the Letter "a" in it.

 

Delete Rows Example

Home

 

Place a range of cells in a Message Box


 

You can loop through a range of cells and place the results in a Message Box

 

vbCrLf is the code for carriage return in vba.

 This will Count the items in the row and works fine if there are no blank cells in the range

 

Sub MsgBoxLoop()

    Dim r As Range, Cnt As Integer, rtn As String

    Dim x As Integer, Msg As String

    

    rtn = vbCrLf

    

    Set r = Range("A1:G1")

    

    Cnt = Application.WorksheetFunction.CountA(r)

    For x = 1 To Cnt

    

        Msg = Msg & Cells(1, x) & rtn

        

    Next x

    MsgBox Msg

End Sub

 

 

 

This will loop through the range, if the cell is not blank then it will add it to the msg

 

Sub MsgBoxLoop2()

    Dim r As Range, rtn As String

    Msg As String, c As Range

    rtn = vbCrLf

    Set r = Range("A1:G1")

    For Each c In r.Cells

        If c <> "" Then

            Msg = Msg & c & rtn

        End If

    Next c

    MsgBox Msg

End Sub

 

UPDATE:

This code is a lot cleaner to get the none blanks

Sub MsgBoxLoop3()

    Dim r As Range, rtn As String

    Dim Msg As String, c As Range

    rtn = vbCrLf

    Set r = Range("A1:G1").SpecialCells(xlCellTypeConstants, 23)

    For Each c In r.Cells

        Msg = Msg & c & rtn

    Next c

    MsgBox Msg

End Sub

 

 

Click the link for more range codes, that you can use in a loop

http/www.davesexcel.com/rangeselectioncodes.htm

http/www.davesexcel.com/vbacodes.htm

 Home

 

Alternate to looping by using Evaluate

If you wanted to Multiply a range of cells by a value, in this case the value is determined by an InputBox and the range will be in Column B

 A loop would be a good way to do this, the InputBox code is just copied from the VBA help file

Sub LoopRng()

    Dim Rws As Long, Rng As Range, c As Range

    Dim Message, Title, Default, MyValue
    Message = "Enter Number to multiply by"    ' Set prompt.
    Title = "InputBox Demo"    ' Set title.
    Default = "1"    ' Set default.
    ' Display message, title, and default value.
    MyValue = InputBox(Message, Title, Default)

    Rws = Cells(Rows.Count, "B").End(xlUp).Row
    Set Rng = Range(Cells(2, 2), Cells(Rws, 2))'Column B Row 2 to last row
'----------------------------------------------------
    For Each c In Rng.Cells
        c = c * MyValue
    Next c

End Sub

The alternative to this and increasing the speed by 98% would be to use evaluate.

Sub EvaluateRng()

    Dim Rws As Long, Rng As Range, c As Range

    Dim Message, Title, Default, MyValue
    Message = "Enter Number to multiply by"    ' Set prompt.
    Title = "InputBox Demo"    ' Set title.
    Default = "1"    ' Set default.
    ' Display message, title, and default value.
    MyValue = InputBox(Message, Title, Default)

    Rws = Cells(Rows.Count, "B").End(xlUp).Row
    Set Rng = Range(Cells(2, 2), Cells(Rws, 2))
'Column B Row 2 to last row
'----------------------------------------------------------
    Rng = Evaluate(Rng.Address & "*" & MyValue)
    
End Sub

 Home

Place selected cell in center of screen

You can count how many visible rows and columns are on the screen.

 

VisC = ActiveWindow.VisibleRange.Columns.Count

VisR = ActiveWindow.VisibleRange.Rows.Count

 

If you use your macro recorder and click on the scroll bar you will get code like this

 

    ActiveWindow.SmallScroll ToRight:=3

 

If you want to find a specific value in a worksheet like todays date then you could use the find approach

 

Set C = Cells.Find(Date)

If Not C Is Nothing Then Application.Goto Reference:=C, scroll:=True

 

Scroll=true, is the important factor here, it places the cell to the top left corner of the screen.

 

Now we take the visible column and row count and divide it by 2 to scroll to the center of the screen

 

ActiveWindow.SmallScroll ToRight:=-VisC / 2

ActiveWindow.SmallScroll Down:=-VisR / 2

 

So we end up with this code

 

Sub ScrollToCenter()

Dim C As Range, VisC As Single, VisR As Single

VisC = ActiveWindow.VisibleRange.Columns.Count

VisR = ActiveWindow.VisibleRange.Rows.Count

Set C = Cells.Find(Date)

If Not C Is Nothing Then Application.Goto Reference:=C, scroll:=True

 

ActiveWindow.SmallScroll ToRight:=-VisC / 2

ActiveWindow.SmallScroll Down:=-VisR / 2

end sub

 

 Home

GetOpenFilename codes

Excels VBA help folder shows this example of how to use GetOpenFilename.

 

Example

 

This example displays the Open dialog box, with the file filter set to text files. If the user chooses a file name, the code displays that file name in a message box.

'*********************************

Visual Basic for ApplicationsfileToOpen = Application _

.GetOpenFilename("Text Files (*.txt), *.txt")

If fileToOpen <> False Then

MsgBox "Open " & fileToOpen

End If

'*********************************

 

But does not explain what to do with your selected files. Why would you want a MsgBox to pop up telling you what you selected when you click open? If you click open, would you not want the file to open?

This Thread is dedicated to...

GetOpenFilename

 

The excel help example can be edited to this

'***********************************************

Sub GetOpenFilename()

 

    Dim FileToOpen As Variant

 

    FileToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Open The Workbook")

    If FileToOpen <> False Then

        Workbooks.Open Filename:=FileToOpen

    End If

 

End Sub

 

 

'********************************************

Select Multiple .xls files

'*******************************************

Sub MultiSelectWorkbooks()

 

    Dim GetFile As Variant

    GetFile = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls), *.xls", Title:="Open The Workbook", MultiSelect:=True)

 

    On Error Resume Next

    If GetFile <> False Then

        On Error GoTo 0

 

        For i = 1 To UBound(GetFile)

            Workbooks.Open Filename:=GetFile(i)

        Next i

    End If

 

End Sub

 

 

'*******************************************

Sometimes Workbooks.open will not work and another solution would be required.

'********************************************

Sub OpenFile()

 

    Dim FileToOpen As Variant

 

    FileToOpen = Application _

                 .GetOpenFilename("Text Files (*.txt), *.txt")

    If FileToOpen <> False Then

        ActiveWorkbook.FollowHyperlink FileToOpen

    End If

 

End Sub

 

 Home

'*******************************************

Loop Through A String

This code will loop through the string in A1 and place each character into Column B

 

'***************************************************

 

Sub ListStringIntoB()

 

'Loop through string, list characters into columnB

 

    Dim str As String, Cnt As Integer, A1 As Range, Lp As Integer

    Dim Rws As Long, Rng As Range, r As Range

 

    Set A1 = Range("A1")

    str = A1

    Cnt = Len(A1)

 

    For Lp = 1 To Cnt

 

        Rws = Cells(Rows.Count, "B").End(xlUp).Row + 1

        Set Rng = Cells(Rws, 2)

 

        Rng = Mid(str, Lp, 1)

 

    Next Lp

 

 

End Sub

 

 

 Home

'****************************************************************

Automating Worksheets with Worksheet Events

You can make your worksheets more automated with Worksheet Events


Right click on the sheet tab and select View code, this takes you to the worksheet module where the Worksheet_Event codes go.

 

 

 

 

 

 

Private Sub Worksheet_Activate()

 

    Dim Str As String, D1 As Range

 

    Set D1 = Range("D1")

 

    Str = Application.InputBox("Enter a value for D1", "Hello, this is sheet " & Me.Name)

 

    D1 = Str

 

    MsgBox "You have entered " & Str & " into cell D1"

 

End Sub

 

'**********************************************

 

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

 

 

    If Not Application.Intersect(Target, Me.Range("A13:B23")) Is Nothing Then

 

        Cancel = True

 

        MsgBox "You have Double Clicked on " & Target.Address

 

    End If

 

End Sub

'**********************************************

 

 

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)

 

    If Not Application.Intersect(Target, Me.Range("C13:d23")) Is Nothing Then

 

        Cancel = True

 

        MsgBox "You have Right Clicked on " & Target.Address

 

    End If

 

End Sub

'************************************************

 

Private Sub Worksheet_Calculate()

 

'Formula in A1 is =E1

'changing E1 will not Be considered a change with the worksheet change event

    MsgBox "Cell A1 Formula has changed to " & Range("E1")

 

End Sub

 

'********************************************

 

 

 

Private Sub Worksheet_Change(ByVal Target As Range)

 

    If Target.Count > 1 Then Exit Sub    ' this stops code error if more than one cell is changed at once

 

    If Not Application.Intersect(Target, Me.Range("A1:C10")) Is Nothing Then    ' indicates the Target range

        MsgBox "You have changed " & Target.Address & " to " & Target

 

    End If

 

End Sub

'*************************************

 

 

Private Sub Worksheet_Deactivate()

 

    MsgBox " You have just left " & Me.Name & " ,see ya later"

 

End Sub

 

'*******************************************

 

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)

 

    Select Case Target.TextToDisplay

    Case "Apples"

        RunApple

    Case "Oranges"

        RunOranges

    Case "Banana"

        RunBanana

    Case "Trees"

        RunTrees

    End Select

 

End Sub

'****************************************

 

 

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

    MsgBox "Not familiar with Pivot Tables"

End Sub

 

'******************************************

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub    ' this stops code error if more than one cell is selected at once

 

    If Not Application.Intersect(Target, Me.Range("E13:J23")) Is Nothing Then    ' indicates the Target range

        MsgBox "You have selected " & Target.Address & " to " & Target

    End If

 

    If Target.Column = 13 Then MsgBox "You have selected " & Target.Address & " in Column M"

 

End Sub

 

 

 

 

Download the Sanple

 

http/www.davesexcel.com/WorksheetEventExamples.xlsm

Codes will work for most excel versions

 

 Home

Entering dates onto a worksheet - Excel VBA

Using the Key Combination

 Ctrl & :

is the fastest way to enter todays date.

 

=Today()

Is the formula for todays date.

 

=Now()

Is the formula for todays date and time

 

Some VBA to enter dates

 

Sub EnterDates()

Dim d As Date, f As Date

d = Now

f = d - 10

Range("A1") = Date

Range("A2") = Now

Range("A3") = Format(Now, "mmmm dd,yyyy  hh:mm am/pm")

Range("A4") = Format(Date, "mmmm dd,yyyy")

Range("A5") = d

Range("A6") = f

Range("A7") = DateDiff("d", d, f)

Range("A8") = "The difference is " & DateDiff("d", f, d) & " days"

End Sub

 

Enter a date in a cell when you open the workbook

 

Private Sub Workbook_Open()

Worksheets("Sheet1").Range("A1") = Format(Now, "mmmm dd,yyyy  hh:mm am/pm")

End Sub

 

Using worksheet change event to enter a date in Column B when you enter something in Column A

 

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Count > 1 Then Exit Sub

    If Target.Column <> 1 Then Exit Sub

    Target.Offset(0, 1) = Date

    Target.Offset(0, 2) = Now

    Target.Offset(0, 3) = Format(Date, "mmmm dd,yyyy")

    Target.Offset(0, 4) = Format(Now, "mmmm dd,yyyy  hh:mm am/pm")

  

End subHome

 

Create a Button and make a macro for it

This code will add a button onto the sheet and write it's own macro, it can only be run once as it is because if you run it again, you will be duplicating the maco.

 

Sub AddButtonMakeMacro()
    Dim MySht As Worksheet
    Dim MyOle As OLEObject

    Set MySht = ActiveSheet
    MySht.Range("H1").Select
    Set MyOle = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
                                           Left:=237.75, Top:=21, Width:=93, Height:=22.5)

    With MyOle
        .Object.Caption = "Click Me"
        .Name = "myMacro"
    End With

    With ThisWorkbook.VBProject.VBComponents(MySht.CodeName).CodeModule
        .InsertLines .CreateEventProc("Click", MyOle.Name) + 1, _
                     vbTab & "If Range(""A1"").Value="" Then " & vbCrLf & _
                     vbTab & vbTab & "Msgbox ""There is nothing in A1""" & vbCrLf & _
                     vbTab & "End If"

    End With

End Sub

 Home

 

Insert Picture from Folder

I got this code from Dave Peterson many years ago in Google Groups. I am placing it here so I can find it faster.

The code will let you search for a picture file in a selected folder, and place it in your selected cell.

 

<code>

Private Declare Function SetCurrentDirectoryA Lib _
                                              "kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
    Dim lReturn As Long
    lReturn = SetCurrentDirectoryA(szPath)
    If lReturn = 0 Then Err.Raise vbObjectError + 1, "Error setting path."
End Sub

Sub testme01()

    Dim myPictureName As Variant
    Dim myPict As Picture
    Dim myRng As Range
    Dim myCurFolder As String
    Dim myNewFolder As String

    myCurFolder = CurDir
    myNewFolder = "yourfoldernamehere"

    On Error Resume Next
    ChDirNet myNewFolder
    If Err.Number <> 0 Then
        'what should happen
        MsgBox "Please change to your own folder"
        Err.Clear
    End If
    On Error GoTo 0

    myPictureName = Application.GetOpenFilename _
                    (filefilter:="Picture Files,*.jpg;*.bmp;*.tif;*.gif")

    ChDirNet myCurFolder

    If myPictureName = False Then
        Exit Sub    'user hit cancel
    End If

    Set myRng = Selection.Areas(1)
    Set myPict = myRng.Parent.Pictures.Insert(myPictureName)
    myPict.Top = myRng.Top
    myPict.Width = myRng.Width
    myPict.Height = myRng.Height
    myPict.Left = myRng.Left
    myPict.Placement = xlMoveAndSize

End Sub

</code>

 Home