davesexcel.com

Copy a file from one folder to another folder

This will copy one file from a folder to another folder

Sub CopyToDifferentFolder()

    FileCopy "C:\Users\Dave\Downloads\SourceFolder\OriginalWorkbook.xlsm", _

             "C:\Users\Dave\Downloads\DestinationFolder\OriginalWorkbook.xlsm"

End Sub

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

Sub CopyToDifferentFolder_Rename()

    FileCopy "C:\Users\Dave\Downloads\SourceFolder\OriginalWorkbook.xlsm", _

             "C:\Users\Dave\Downloads\DestinationFolder\NewWorkbook.xlsm"

End Sub

Copy 2 files from folder to another folder

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

Copy 2 files from folder to another folder and rename file

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

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 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

Get data from many workbooks in a folder.

This code will loop through a folder called "WorkBookLoop".

The code then Copies and pastes whatever is in column A:B and paste it to the workbook that is running the code.

Sub LoopThroughFolder()

    Dim MyFile As String, Str As String, MyDir As String, Wb As Workbook

    Dim Rws As Long, Rng As Range

    Set Wb = ThisWorkbook

    'change the address to suite

    MyDir = "C:\WorkBookLoop\"

    MyFile = Dir(MyDir & "*.xls") 'change file extension

    ChDir MyDir

    Application.ScreenUpdating = 0

    Application.DisplayAlerts = 0

    Do While MyFile <> ""

        Workbooks.Open (MyFile)

        With Worksheets("Sheet1")

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

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

            Rng.Copy Wb.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

            ActiveWorkbook.Close True

        End With

        Application.DisplayAlerts = 1

        MyFile = Dir()

    Loop

End Sub

Select a file to be emailed using excel VBA

This example uses three combo boxes to select the folder,file,then email address to send a file.

This 1st code will list the subfolders from the C:\ drive and populate a combobox that is on the worksheet. The combobox and command button are drawn from the controls toolbar and the code is located in the worksheet module.

Private Sub CommandButton1_Click()

    Dim fs, f, f1, fc, s

    Dim folderspec

    folderspec = "C:\"

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.GetFolder(folderspec)

    Set fc = f.SubFolders

    ComboBox1.Clear

    For Each f1 In fc

        ComboBox1.AddItem f1.Name

    Next f1

    ComboBox1.Activate

    Application.SendKeys "^{F4}"

End Sub

Once you have made a folder selection from combobox1, combobox2 then needs to be populated with the file names from the selected folder.

Private Sub ComboBox1_Change()

    Dim fs, f, f1, fc, s

    Dim folderspec

    folderspec = "C:\" & ComboBox1

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.GetFolder(folderspec)

    Set fc = f.Files

    ComboBox2.Clear

    For Each f1 In fc

        ComboBox2.AddItem f1.Name

    Next f1

    ComboBox2.Activate

    Application.SendKeys "^{F4}"

End Sub

Now combobox2 will dropdown, and you can select a file to be attached to your email.

Once you have selected a file to attach, a code will activate to populate combobox3 with a list of contacts from your Outlook Account. This macro is called "select_Email".

Private Sub ComboBox2_Change()

    select_Email

    ComboBox3.Activate

    Application.SendKeys "^{F4}"

End Sub

Code to get contacts list

Sub select_Email()

    Dim olApp As Object

    Dim Cbo As Object

    Dim Contact As Object

    Dim ContactsFolder As Object

    Set Cbo = Worksheets("Sheet1").OLEObjects("ComboBox3").Object

    Cbo.Clear

    Set olApp = CreateObject("Outlook.Application")

    Set ContactsFolder = olApp.Session.GetDefaultFolder(10)

    For Each Contact In ContactsFolder.Items

        Cbo.AddItem Contact.FullName

    Next Contact

    olApp.Quit

    Set olApp = Nothing

End Sub

Now for the Email code

Sub SendEmail()

    Dim OutlookApp As Object

    Dim mItem As Object

    Dim Cell As Range

    Dim Subj As String

    Dim EmailAddr As String

    Dim Bonus As String

    Dim Msg As String

    Dim Body As String

    Set OutlookApp = CreateObject("Outlook.Application")

    Body = Range("D20")

    Subj = ActiveSheet.ComboBox2

    EmailAddr = ActiveSheet.ComboBox3

    Set mItem = OutlookApp.createitem(0)

    With mItem

        On Error GoTo ExitPoint

        strPath = "C:\" & ActiveSheet.ComboBox1 & "\" & ActiveSheet.ComboBox2

        vDir = Dir(strPath)

        .Attachments.Add Replace(strPath, "*.*", vDir)

        vDir = Dir()

        If .Attachments.Count = 0 Then

            If MsgBox("Invalid Path - Cancel Mail ?", vbYesNo, "Cancel") = vbYes Then

                .Delete

                GoTo ExitPoint

            End If

        End If

        .To = EmailAddr

        .Subject = Subj

        .Body = Body

        .display

    End With

ExitPoint:

    Set OLMsg = Nothing

End Sub

You may have noticed this bit of code in a few of the macros

ComboBox2.Activate   

Application.SendKeys "^{F4}"

This is used to auto drop the combobox.

Check out the example workbook

http://www.davesexcel.com/Email%20A%20File.xlsm

http://www.davesexcel.com/Email%20A%20File.xls

If you want the user to enter a password before completing an action use a User Form.

How to make a userform click the link.

http://www.davesexcel.com/createauserform.htm

Create your userform and draw a textbox and two buttons on it.

Select the textbox and then in the properties window under PasswordChar enter * (astrix)

Use this code in the UserForm

Private Sub CommandButton1_Click()

'ok button

    If TextBox1 = "123456" Then

        MsgBox "you have the correct password"

    Else

        MsgBox "wrong password"

    End If

    Unload Me

End Sub

Private Sub CommandButton2_Click()

'cancel button

    Unload Me

End Sub

Private Sub UserForm_Initialize()

Me.Caption = "Enter Password"

End Sub

You finish Password Userform

I want a screen to pop up when I Open an Excel Workbook and then the screen closes after 5 seconds.

This can be done by creating a UserForm, and then use VBA code to Show the userform.(Splash Screen)

We use 3 types of modules here

1. TheWorkbook Module
2. The UserForm Module
3. The Regular Module

First create the Userform that you want to pop up when you open the workbook.

In the VBA editor at the Top Menu bar, select Insert=>Userform

Select the Label Control from the Toobox and draw it on the userform. When you have the label selected you can go into the labels Properties window and set the text font you want to display when the UserForm Pops up.

In the Workbook Module enter this code.

Private Sub Workbook_Open()

    With UserForm1

        .StartUpPosition = 0

        .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)

        .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)

        .Show

    End With

End Sub

In the Userform Module enter this code.

Private Sub UserForm_Initialize()

    Application.OnTime Now + TimeValue("00:00:05"), "unloadscreen"

End Sub

Private Sub UserForm_QueryClose _

        (Cancel As Integer, CloseMode As Integer)

'Stop the use of the close button

    If CloseMode = vbFormControlMenu Then

        MsgBox "You cannot use the close button"

        Cancel = True

    End If

End Sub

In a Regular Module use this code

Sub UnloadScreen()

    Unload UserForm1

End Sub

 Save and close the workbook, then open it.

If you do not know how to create a UserForm check out this link.

How to Create A UserForm

Checkout the examples

Make Screen Pop Up on Open Using xl 97_03

For newer versions

Excel 2007 and Newer

I want to add buttons, name them and assign macros to them.

Use this code, it will add buttons to A1:A3, name each button and assign a macro to them.

Make sure you have the macros in place before you run the CreateButtons code.

Sub CreateButtons()

    Dim butn As Button, Rng As Range, c As Range, i

    i = 1

    With Worksheets("Sheet1")

        Set Rng = .Range("A1:A3")

        For Each c In Rng.Cells

            Set butn = .Buttons.Add(c.Left, c.Top, c.Width, c.Height)

            With butn

                .Caption = "Macro" & i

                .OnAction = "Macro" & i

            End With

            i = i + 1

        Next c

    End With

End Sub

Sub Macro1()

    MsgBox "Macro1"

End Sub

Sub Macro2()

    MsgBox "Macro2"

End Sub

Sub Macro3()

    MsgBox "Macro3"

End Sub

These codes will populate ListBoxes from the controls toolbar.

Populate a ListBox with Unique Items from Column A

Private Sub CommandButton1_Click()

'Written by Dave Morrison

'November 17, 2010

'This code will populate ListBox1 with items from Column1, with no duplicates

    Dim rng As Range, c As Range, r As Range

    Dim rws As Long, y As Integer

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

    ListBox1.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 ListBox1.AddItem c

    Next c

End Sub

Populate a ListBox with 3 columns

Private Sub CommandButton2_Click()

    Dim rng As Range, c As Range, r As Range

    Dim rws As Long, y As Integer

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

    ListBox2.Clear

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

    ListBox2.ColumnCount = 3

    With ListBox2

        .List = r.Value

    End With

End Sub

Populate a ComboBox with Unique Items

Private Sub CommandButton3_Click()

'Written by Dave Morrison

'November 17, 2010

'This code will populate ComboBox1 with items from Column1, with no duplicates

    Dim rng As Range, c As Range, r As Range

    Dim rws As Long, y As Integer

    rws = Me.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.Value

    Next c

End Sub

When you make a selection in the ComboBox the listbox beside it will Populate only with the Items you selected from the ComboBox.

Private Sub ComboBox1_click()

    Dim rng As Range, c As Range, r As Range

    Dim rws As Long, y As Integer

    Dim Frng As Range, Frws As Long

    Application.ScreenUpdating = False

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

    Columns("A:A").AutoFilter Field:=1, Criteria1:=ComboBox1

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

    r.SpecialCells(xlCellTypeVisible).Copy Destination:=Range("A100")    'Sends filtered range to A1

    Columns("A:A").AutoFilter

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

    Set Frng = Range(Cells(100, 1), Cells(Frws, 3))

    ListBox3.ColumnCount = 3

    With ListBox3

        .Clear

        .List = Frng.Value

    End With

    Frng.Clear

    Application.Goto Reference:="R8C1", Scroll:=True

End Sub

The last code is the most difficult, the filtered range has to be moved to a new location, that new location is then used to populate the list box.

Check out the example

http://www.davesexcel.com/ListBoxCodes.xlsm

Create a list of months for each row in Column A

Sub ListMonthInRow()

Dim c As Long

For c = 1 To 12

Cells(c, 1) = Format(DateSerial(2012, c, 1), "mmmm")

Next c

End Sub

Create a list of months In Row 1

Sub ListMonthInColumn()

Dim c As Long

For c = 1 To 12

Cells(1, c) = Format(DateSerial(2012, c, 1), "mmmm")

Next c

End Sub

Create a list of months in a combobox from the controls tool bar

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim c As Long

    For c = 1 To 12

        ComboBox1.AddItem Format(DateSerial(2012, c, 1), "mmmm")

    Next c

 Create a list of months in a combobox in a userform

Private Sub UserForm_Initialize()

    Dim c As Long

    For c = 1 To 12

        ComboBox1.AddItem Format(DateSerial(2012, c, 1), "mmmm")

    Next c

End Sub

I want to add a comment to H1 and place what is in Cell A1 to be in the comment.

You can use VBA to add a comment and have what is in A1 in the comment box.

Sub CommentBox()

    Dim A1 As Range

    Set A1 = Range("A1")

    With Range("H1")

        .Comment.Delete

        .AddComment

        .Comment.Visible = False

        .Comment.Text Text:=A1.Text

        .Comment.Shape.TextFrame.AutoSize = True

    End With

End Sub

You have an If statement in Cell B1 that goes like this.

=IF(A1=20,"Yep","Nope")

In VBA the code would be.

Sub VBA_If_Statement()

    Dim Ar As Range

    Set Ar = Range("A1")

    Range("B1") = IIf(Ar = 20, "Yep", "Nope")

End Sub

An If statement in VBA is IIf

This is the long version of the same results

Sub VBA_If_Statement_Long_Version()

    Dim Ar As Range

    Set Ar = Range("A1")

    If Ar = 20 Then

        Range("B1") = "Yep"

    Else: Range("B1") = "Nope"

    End If

End Sub

You can use a Worksheet_Change event to make B1 change when A1 changes

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Address <> "$A$1" Then Exit Sub

    Range("B1") = IIf(Target = 20, "Yep", "Nope")

End Sub