|
![]() |
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
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.
Checkout the examples
Make Screen Pop Up on Open Using xl 97_03
For newer versions
|
![]() |
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
|
![]() |
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