XLorate by davesexcel

Sub Button1_Click()
    Dim sh As Shape
    Set sh = Sheets("Sheet1").Shapes("Textbox 1")
    sh.TextFrame.Characters.Font.Color = vbBlue
End Sub


If you want to Get the unique items use one of these codes.

excel VBA extract unique, get unique, no duplicates ,extract duplicates,remove duplicates

Extract Unique Items in a Column

Sometimes you want to start typing in a textbox and the list will AutoFilter as you type.

Private Sub ComboBox1_Change()
    Dim Rws As Long, Rng As Range, x
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    
    Set Rng = Range(Cells(1, 1), Cells(Rws, 2))
    
    x = Application.WorksheetFunction.VLookup(ComboBox1, Rng, 2, 0)
    
    TextBox1 = x
    
End Sub


Vlookup In UserForm


Select item in ComboBox and Return value in textbox



Untitled 1

Extract Time from cell with date and time

 


Format cell as required


Formula in I5=


=SUMPRODUCT(($B$5:$B$25=G5)*($A$5:$A$25=$I$4)*($C$5:$C$25))



Formula in H5=


=SUMPRODUCT(($B$5:$B$25=G5)*($A$5:$A$25=$H$4)*($C$5:$C$25))


Sumproduct 2 Criteria

Sub CopyFileNewname()
    Dim SrceFile1, SrceFile2
    Dim DestFile1, DestFile2

    SrceFile1 = "C:\SourceFolder\Source1.xls"
    SrceFile2 = "C:\SourceFolder\Source2.xls"

    DestFile1 = "C:\DestinationFolder\New1.xls"
    DestFile2 = "C:\DestinationFolder\New2.xls"

    FileCopy SrceFile1, DestFile1
    FileCopy SrceFile2, DestFile2

End Sub

Sub CopyFiles()
    Dim SrceFile1, SrceFile2
    Dim DestFile1, DestFile2
    
    SrceFile1 = "C:\SourceFolder\Source1.xls"
    SrceFile2 = "C:\SourceFolder\Source2.xls"
    
    DestFile1 = "C:\DestinationFolder\Source1.xls"
    DestFile2 = "C:\DestinationFolder\Source2.xls"
    
    FileCopy SrceFile1, DestFile1
    FileCopy SrceFile2, DestFile2

End Sub


This will copy one file from a folder to another folder

Copy 2 files from folder to another folder and rename file

calculate area in a chart,calculate area in poygon

View the Code

Adding the Developer Tab to the Ribbon

Adding the Developer Tab to Ribbon, add developer tab,excel developer tab,where is the developer tab?,VBA Developer Tab. Developer Ribbon

Insert the Button or Shape

Find the range of the button when clicked

Find range of the shape when clicked


Sub AddBorders()
    Dim Rws As Long, Rng As Range, c As Range

    Rws = Range("A1").SpecialCells(xlCellTypeLastCell).Row
    Set Rng = Range(Cells(1, "A"), Cells(Rws, "E"))

    For Each c In Rng.Cells

        If c <> "" Then

            With c.Borders

                .LineStyle = xlContinuous
                .Weight = xlThin
                .ColorIndex = xlAutomatic

            End With

        End If

    Next c

End Sub



Sub Copy_Transpose()
    Dim Ra As Range

    Application.ScreenUpdating = False
    For Each Ra In Columns("A").SpecialCells(xlCellTypeConstants, 23).Areas
        Ra.Copy
        Worksheets("Sheet2"). _
                Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
    Next Ra
    Application.CutCopyMode = False
End Sub



If you are going to do any amount of VBA coding, it would be best to place the developer tab to your Ribbon. It gives you access to the VBA Editor, insert controls, and the Macro Controler

Click Button or Shape

Private Sub FilterText_Change()

    Range("$A$1").AutoFilter Field:=1, Visibledropdown:=False    'hides the drop down arrows
    Range("$A$1").AutoFilter Field:=1, Criteria1:="=*" & FilterText & "*"

End Sub



Select the Macro

Place code in VBA Regular Module

Lookup value using 2 criteria

AutoFilter as you Type



Dim rng As Range, c As Range, r As Range, f As Range
Dim rws As Long, y As Integer
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Address <> "$C$1" Then Exit Sub

    rws = ActiveSheet.UsedRange.Columns(1).Rows.Count

    ComboBox1.Clear

    Set r = Range(Cells(2, 1), Cells(rws, 1))

    For Each c In r.Cells
        y = Application.WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(c.Row, 1)), c)
        If y = 1 Then ComboBox1.AddItem c
    Next c

    With ComboBox1
        .Activate
        .Application.SendKeys ("%{down}")
    End With

End Sub
Private Sub ComboBox1_Change()
    rws = ActiveSheet.UsedRange.Columns(1).Rows.Count

    ComboBox2.Clear

    Set r = Range(Cells(1, 1), Cells(rws, 1))

    For Each c In r.Cells
        If c = ComboBox1 Then ComboBox2.AddItem c.Offset(0, 1)
    Next c

    With ComboBox2
        .Activate
        .Application.SendKeys ("%{down}")
    End With

End Sub
Private Sub ComboBox2_Change()
    Set f = Range("F16")
    f = ComboBox1 & " " & ComboBox2
    f.Select
End Sub


Dependent ComboBox

Copy Transpose a range of areas to a different sheet

Using the Macro Recorder

Sub RangeOfButtonOrShape()
    Dim r As Range
    Set r = ActiveSheet.Shapes(Application.Caller).TopLeftCell    'find the range of the button clicked.
    MsgBox r.Address & " is the range of the shape clicked"
    r.Offset(0, 3) = "Hello"
End Sub



Find Button Range

Sub CopyFileAddDate()
    Dim SrceFile1, SrceFile2
    Dim DestFile1, DestFile2

    SrceFile1 = "C:\SourceFolder\Source1.xls"
    SrceFile2 = "C:\SourceFolder\Source2.xls"

    DestFile1 = "C:\DestinationFolder\Source1 " & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".xls"
    DestFile2 = "C:\DestinationFolder\Source2 " & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".xls"

    FileCopy SrceFile1, DestFile1
    FileCopy SrceFile2, DestFile2

End Sub



Sub UsingCollection()
    Dim cUnique As Collection
    Dim Rng As Range
    Dim Cell As Range
    Dim sh As Worksheet
    Dim vNum As Variant

    Set sh = ThisWorkbook.Sheets("Sheet1")
    Set Rng = sh.Range("A2", sh.Range("A2").End(xlDown))
    Set cUnique = New Collection

    On Error Resume Next
    For Each Cell In Rng.Cells
        cUnique.Add Cell.Value, CStr(Cell.Value)
    Next Cell
    On Error GoTo 0

    For Each vNum In cUnique
        Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = vNum

    Next vNum

End Sub



Sub UsingCount()
    Dim Rws As Long, Rng As Range, c As Range, y As Integer, x
    Rws = Cells(Rows.Count, "A").End(xlUp).Row
    For y = 2 To Rws
        Set c = Cells(y, 1)
        Set Rng = Range(Cells(2, 1), Cells(y, 1))
        x = Application.WorksheetFunction.CountIf(Rng, c)
        If x = 1 Then Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = c
    Next y

End Sub



Copy 2 files from  folder to another folder

This will copy one file from a folder to another folder and rename it.

Sub CopyToDifferentFolder()
    FileCopy "C:\Users\Dave\Downloads\SourceFolder\OriginalWorkbook.xlsm", _
             "C:\Users\Dave\Downloads\DestinationFolder\OriginalWorkbook.xlsm"
End Sub



Copy Files to a different folder

Sub CopyToDifferentFolder_Rename()
    FileCopy "C:\Users\Dave\Downloads\SourceFolder\OriginalWorkbook.xlsm", _
             "C:\Users\Dave\Downloads\DestinationFolder\NewWorkbook.xlsm"
End Sub

You may want to copy files from one folder to another folder and rename the files with a Date and Time Stamp. Some people want to do this for back-up reasons.

Macro to add borders,add cell borders macro,border macro,add borders to cells,VBA borders to cells?

Excel VBA Adding Cell Borders

Calculate Area in a Chart

Color text in Textbox  from other sheet

Click Visual Basics to get into The VBA Editor

The Excel Developer Tab