XLorate by davesexcel

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.

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

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 Button1_Click()
    Dim sh As Shape
    Set sh = Sheets("Sheet1").Shapes("Textbox 1")
    sh.TextFrame.Characters.Font.Color = vbBlue
End Sub


Color text in Textbox  from other sheet

Copy Transpose a range of areas to a different sheet

View the Code

Using the Macro Recorder

Click Visual Basics to get into The VBA Editor

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

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

The Excel Developer Tab



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



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

Click Button or Shape

Select the Macro

Place code in VBA Regular Module

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



Insert the Button or Shape

Find the range of the button when clicked

Find range of the shape when clicked

Find Button Range

Lookup value using 2 criteria

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



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

AutoFilter as you Type


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

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

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

Calculate Area in a Chart


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





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


calculate area in a chart,calculate area in poygon


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


Excel VBA Adding Cell Borders

Dependent ComboBox