Collection of VBA scripts

This collection of VBA scripts has been created throughout the projects created by Datanology. Whilst we re-use and find further uses for them, we’ll add them to this blog, but for now they’re fully searchable, and we will continue to add to it as often as possible.



Useful VBA

Copy worksheet XLSW and check if exists

y = Replace(Now(), "/", "")
x = Replace(y, ":", "")
On Error Resume Next
Set wsSheet = Sheets("XLSW")
On Error GoTo 0

Sheets(("XLSW").Copy After:=Sheets("Sheet1")
ActiveSheet.Cells.ClearContents
ActiveSheet.Range("B2") = ComboBox1
p = ActiveSheet.Name
Else
Sheets("Template").Copy After:=Sheets("Strategies")
ActiveSheet.Name = ComboBox1
ActiveSheet.Range("B2") = ComboBox1
p = ActiveSheet.Name
End If

Find the last used row in a column:


Sub Find_lastrow_Col_B()
With Sheets("sheet1")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
End Sub


This short routine will find the last used row in a worksheet. In this instance, we have chosen sheet1 and will look right the way down Column B. It's important to note it finds the last cell that has a value. If you intend to add anything to this as an ongoing list, you will need to consider a +1 in your code.

Rename a Worksheet:


Sub Rename_Worksheet()
Sheets("OldSheet").Name = "Newsheet"
End Sub


This is a very basic command to rename a worksheet. This is the basis of how you would begin to rename multiple sheets if they are statically named. More complex routines with regards renaming sheets are available for a whole host of scenarios.

Find the last used column in a row:


Sub Find_lastcol_row_1()
With Sheets("sheet1")
lastcol = Cells(.Rows.Count, "E").End(xlUp).Row
End With
End Sub


This short routine will find the last used column in a particular row in a worksheet. In this instance, we have chosen sheet1
and will look right the way down Column B. It's important to note it finds the last cell that has a value. If you intend to add anything to this as an ongoing list, you will need to consider a +1 in your code.

Split groups of duplicates in a constant list:


Sub Insert_row_between_groups_in_list()
For n = 1 To 28
Worksheets("Sheet1").Range("A" & n).Select
b = Worksheets("Sheet1").Range("A" & n + 1)
If Selection <> b Then
ActiveCell.Offset(1).EntireRow.Insert
n = n + 1
End If
Next n
End Sub


This script looks down column A and determines the end of a group of duplicates, then inserts a blank row before moving on to the start of the next group and applies the same actions.

List the worksheet names in current workbook:


Sub SheetNames()
Columns(1).Insert
For i = 1 To Sheets.Count
Cells(i, 1) = Sheets(i).Name
Next i
End Sub


This VBA will get the names of all the tabs in the current workbook and list them in column A of your active worksheet.

Find mean averages in a group and apply the mean to all in the group:


Sub Find_mean_in_ranges()
Application.ScreenUpdating = False
With Sheets("sheet1")
lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
End With
mx = WorksheetFunction.Max(Worksheets("Sheet1").Range("A:A"))
For r = 0 To mx
Count = 0
Stage = 0
For a = 2 To lastrow
If Worksheets("sheet1").Range("A" & a) = r Then
Stage = Stage + Worksheets("sheet1").Range("F" & a)
Count = Count + 1
End If
Next a
x = Val(Stage) / Val(Count)
For p = 2 To lastrow
If Worksheets("sheet1").Range("A" & p) = r Then
Worksheets("sheet1").Range("F" & p) = x
End If
Next p
Next r
For Z = 2 To lastrow
If Worksheets("sheet1").Range("E" & Z) = "1" Then
Worksheets("sheet1").Range("F" & Z) = Worksheets("sheet1").Range("F" & Z) + 600
End If
Next Z
For i = lastrow To 2 Step -1
If Worksheets("sheet1").Range("f" & i) > 9999 Or Worksheets("sheet1").Range("f" & i) < 151 Then
Worksheets("sheet1").Range("a" & i).EntireRow.Delete
End If
Next i
End Sub


This Script will go through column A and find any row that is in the same group (same value). It will then add the values in column F for that group and divide them by the number in the group (ie Mean Average). It will then replace the value in column F for that group with the group mean average. It will detect an error (value 1) in Column E and add 600 to the row value. Its next job is to delete rows where the value in column F is < 151 or > 9999.

Copy worksheet XLSW into same workbook after Sheet1


Sheets("XLSW").Copy After:=Sheets("Sheet1")


This code copies the worksheet named XLSW and puts the copy in the same workbook after the tab named Sheet1.

Simplified formatting of all cells in a column


With Worksheets("XLSW").Columns("C:C")
.HorizontalAlignment = xlRight
.WrapText = True
.VerticalAlignment = xlTop
.Font.Size = 12
.Font.Bold = True
.Interior.ColorIndex = VbRed
End With


This code shows several examples of formatting cells, simplified

MAC version of getting unique values from a list into Combobox1 in a Userform


Dim c As Range, Coll As New Collection
On Error Resume Next
For Each c In Sheets("Strategies").[C2:C25000]
Coll.Add c.Value, c.Value
Next c
On Error GoTo 0
For Each Item In Coll
ComboBox1.AddItem Item
Next Item


This code works on Windows and the MAC, looking through a list on a workbook and putting the uniue values in a combobox. In this example it is Combobox1 and the list of data we are looking to get the unique values from is C2:C5000

Delete Multiple worksheets at the same time


Sheets(Array("Opening", "Type", "Doors", "Size")).Select
ActiveWindow.SelectedSheets.Delete


Deleting multiple worksheets where the name of those worksheets is known can be deleted through this code.

Copy a 'Used' range from 1 worksheet to another (as Paste Special)


Worksheets("Sheet1").UsedRange.Copy
Worksheets("Sheet2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False


This will copy all the data in the actual used range in sheet1 and paste special (Values) into sheet2.

Reformat all of Columns A-E on Sheet1 as centered, Calibri Font and size 10


Sheets("Sheet1").Select
Columns("A:E").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 10
End With


Centering and formatting the data in columns or over the whole page / selection can be accomplished within this 'with' code.

Autofill a range


Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E500"), Type:=xlFillDefault


Selects the formula or text in E2 and drags it down to row 500

Add a new worksheet at the end and name it


Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "New_Sheet"


This will add a new worksheet to the end of your worksheets and name it 'New_Sheet'

Remove Duplicates


ActiveSheet.Range("$A$1:$C$25").RemoveDuplicates Columns:=Array(1, 2, 3), _
Header:=xlYes


Removes the duplicates whilst considering columns A,B & C altogether and confirming the data does have headers.

Prevent closing a Userform by the X box

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
MsgBox "You can not close down DataLink this way. Please 'Double Click' the logo and choose closedown DataLink from there."
Cancel = True
End If
End Sub


You will not be able to close a userform by clicking on the X at the top right. Make sure you have an escape route added if you ever need to come out of it in development, or in future development.

Instr – Searching and finding text within text


X = Instr(1,"Excel","c")
Msgbox x


X = 3 as Instr has found 'c' as the third letter in Excel, starting form the 1st letter. Ucase/Lcase is sometimes needed as Instr is case sensitive.

Spin button control – incrementing


Private Sub SpinButton1_Change()
SpinButton1.Min = 2
SpinButton1.Max = WorksheetFunction.CountA(Worksheets("sheet1").Range("A:A"))
TextBox1.Value = SpinButton1.Value
End Sub


A spin button on a userform can help you to increment between a max and min value that you can set, or you can have VBA set it for instance to the first or last row of a column.

Exporting from Outlook folder to Excel


Sub ExportToExcel()
On Error Resume Next
Set myOlApp = Outlook.Application
Set mynamespace = myOlApp.GetNamespace("mapi")
'open the current folder, I want to be able to name a specific folder if possible…
Set myfolder = myOlApp.ActiveExplorer.CurrentFolder
Set xlobj = CreateObject("excel.application.14")
xlobj.Visible = True
xlobj.Workbooks.Add
'Set Heading
xlobj.Range("a" & 1).Value = "Column 1"
xlobj.Range("b" & 1).Value = "Column 2"
xlobj.Range("c" & 1).Value = "Column 3"
xlobj.Range("d" & 1).Value = "Column 4"
xlobj.Range("e" & 1).Value = "Column 5"
For i = 1 To myfolder.Items.Count
Set myitem = myfolder.Items(i)
msgtext = myitem.Body
'search for specific text
delimtedMessage = Replace(msgtext, "Column 1", "###")
delimtedMessage = Replace(delimtedMessage, "Column 2", "###")
delimtedMessage = Replace(delimtedMessage, "Column 3", "###")
messageArray = Split(delimtedMessage, "###")
'write to excel
xlobj.Range("a" & i + 1).Value = messageArray(0)
xlobj.Range("b" & i + 1).Value = messageArray(1)
xlobj.Range("c" & i + 1).Value = messageArray(2)
xlobj.Range("e" & i + 1).Value = messageArray(3)
xlobj.Range("e" & i + 1).Value = myitem.To
Next
End Sub


This code will allow the extract of all the emails in the current folder, putting them in 5 columns within Excel.

Insert a picture from file using VBA


Sub Button1_Click()
InsertPictureInRange "H:\CVT Administration Team\Schedules Repudiations Apps\Automated VSFs\Client Logos\Service Insurance.jpg", _
Range("E13:I18")
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
If Dir(PictureFileName) = "" Then Exit Sub
' import picture
Set p = ActiveSheet.Pictures.Insert(PictureFileName)
' determine positions
With TargetCells
t = .Top
l = .Left
w = .Offset(0, .Columns.Count).Left - .Left
h = .Offset(.Rows.Count, 0).Top - .Top
End With
' position picture
With p
.Top = t
.Left = l
.Width = w
.Height = h
End With
Set p = Nothing
End Sub


There are 2 sections of code in the above example which will import a picture from file into a specified cell in the activesheet. It will retain its size and ratio so you will need to assign it to the correct cell if you want it centered nicely.

Merge a range of cells


Range("I34:L37").MergeCells = True


A very simple code that will allow you to specify a range in which to merge the cells. Changing the TRUE to FALSE will unmerge the cells in the specified range

Move data, recolour and assign multiple tables in 1 sheet

Reece Source Code


Sub Sumofoutput_Button2_Click()

Worksheets("Sum of Output").Select
Columns("J:J").Select
Selection.Copy

Sheets("Holding").Select
Range("A1").Select
ActiveSheet.Paste

Dim dict As Object
Dim rowCount As Long
Dim strVal As String

Set dict = CreateObject("Scripting.Dictionary")

rowCount = Worksheets("Holding").Range("A1").CurrentRegion.Rows.Count

Do While rowCount > 1
strVal = Worksheets("Holding").Cells(rowCount, 1).Value2

If dict.exists(strVal) Then
Worksheets("Holding").Rows(rowCount).EntireRow.Delete
Else
dict.Add strVal, 0
End If

rowCount = rowCount - 1
Loop

Set dict = Nothing

'Copy top row headers
Sheets("DataHold").Select
Rows("1:1").Select
Selection.Copy
Sheets("ReportX").Select
Rows("1:1").Select
ActiveSheet.Paste

'Loop through Holding 2 to lastrow and copy rows from Sum of Output that J = Loop value
With Sheets("Holding")
lastrowHOLD = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With Sheets("ReportX")
lastrowRPTX = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With Sheets("Sum of Output")
lastrowSUM = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

For n = 2 To lastrowHOLD
For P = 1 To lastrowSUM
x = Worksheets("Holding").Range("A" & n)
y = Worksheets("Sum of Output").Range("J" & P)

If x = y Then
Worksheets("Sum of Output").Range("J" & P).EntireRow.Copy Worksheets("ReportX").Range("A" & lastrowRPTX + 1)
lastrowRPTX = lastrowRPTX + 1
End If

Next P

Sheets("DataHold").Select
Rows("5:6").Select
Selection.Copy Worksheets("ReportX").Cells(lastrowRPTX + 1, 1)
lastrowRPTX = lastrowRPTX + 1

Sheets("DataHold").Select
Rows("1:1").Select
Selection.Copy Worksheets("ReportX").Cells(lastrowRPTX + 2, 1)
lastrowRPTX = lastrowRPTX + 2
'ActiveSheet.Paste

Next n

'Loop to find 1st and next "Theme" in ReportX

Worksheets("Holding").Cells.ClearContents

With Sheets("ReportX")
lastrowRPTX = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

THM = 1

For Rn = 1 To lastrowRPTX
x = Worksheets("ReportX").Range("A" & Rn)
If x = "Theme" Then
Worksheets("Holding").Range("A" & THM) = Rn
THM = THM + 1
End If
Next Rn

With Sheets("Holding")
lastrowHOLD = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

For v = 1 To lastrowHOLD
On Error GoTo NJB
a = Worksheets("Holding").Range("A" & v)
b = Worksheets("Holding").Range("A" & v + 1)

Sheets("DataHold").Select
Rows("2:2").Select
Selection.Copy
Sheets("ReportX").Select
Rows(a + 1 & ":" & b - 3).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

ActiveSheet.ListObjects.Add(xlSrcRange, Range("A" & a & ":J" & b - 2), , xlYes).Name = _
"Table" & v

'b-2 is the row
'b - 3 is the end
'a+1 is the beginning
Worksheets("ReportX").Range("C" & b - 2) = "=SUM(C" & a + 1 & ":C" & b - 3 & ")"
Worksheets("ReportX").Range("E" & b - 2) = "=AVERAGE(E" & a + 1 & ":E" & b - 3 & ")"
Worksheets("ReportX").Range("H" & b - 2) = "=SUM(H" & a + 1 & ":H" & b - 3 & ")"

Worksheets("ReportX").Range("A" & a).EntireRow.Font.Color = vbBlack

Next v

NJB:

With Sheets("ReportX")
lastrowRPTX = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Worksheets("ReportX").Range("A" & lastrowRPTX).EntireRow.Delete shift:=xlUp

Columns("J:J").ColumnWidth = 81
Columns("I:I").ColumnWidth = 11.88
Columns("H:H").ColumnWidth = 9.38
Columns("G:G").Hidden = True
Columns("F:F").ColumnWidth = 37.88
Columns("E:E").ColumnWidth = 12.5
Columns("D:D").ColumnWidth = 18.25
Columns("C:C").ColumnWidth = 41
Columns("B:B").ColumnWidth = 35.75
Columns("A:A").ColumnWidth = 22.25
End Sub

Retaining the original entry in the TextBox from userform when dragged to another

Private Sub TextBox1_Change()
TextBox1.Text = Worksheets("Sheet2").Range("A1")
End Sub


The code says when the value is dragged out and nothing is left, as the textbox has changed, as long as you want to retain the original entry, it will be repopulated by the value it originally put in Sheet2 A1.

Highlight all the text in a Userform TextBox when mouse goes over it

Private Sub TextBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
With TextBox2
.SetFocus
.SelStart = 0
.SelLength = Len(TextBox2.Text)
End With
Worksheets("Sheet2").Range("A1") = TextBox2.Text
End Sub


When the mouse pointer moves over the textbox, it highlights all the text in the textbox. If you have enabled Drag and Drop this is useful. This code goes in the Userform module equivalent. It also puts the value that was in there already, into A1 in Sheet2. This means that if the person drags the text from the textbox, the original value is still intact in Sheet2 A1.

Get the nth word from a cell

Option Compare Text
Function Get_Word(text_string As String, nth_word) As String
Dim lWordCount As Long
With Application.WorksheetFunction
lWordCount = Len(text_string) - Len(.Substitute(text_string, " ", "")) + 1
If IsNumeric(nth_word) Then
nth_word = nth_word - 1
Get_Word = Mid(Mid(Mid(.Substitute(text_string, " ", "^", nth_word), 1, 256), _
.Find("^", .Substitute(text_string, " ", "^", nth_word)), 256), 2, _
.Find(" ", Mid(Mid(.Substitute(text_string, " ", "^", nth_word), 1, 256), _
.Find("^", .Substitute(text_string, " ", "^", nth_word)), 256)) - 2)
ElseIf nth_word = "First" Then
Get_Word = Left(text_string, .Find(" ", text_string) - 1)
ElseIf nth_word = "Last" Then
Get_Word = Mid(.Substitute(text_string, " ", "^", Len(text_string) - _
Len(.Substitute(text_string, " ", ""))), .Find("^", .Substitute(text_string, " ", "^", _
Len(text_string) - Len(.Substitute(text_string, " ", "")))) + 1, 256)
End If
End With
End Function


This is another function that will extract the nth word from a cell using the formula =Get_word(A1,6) which will get the 6th word in cell A1 and put it in the cell where the formula is written. In VBA use the function in the module you are working in and use worksheetfunction.Get_Word. There are limitations to this formual/function in that it will return an error if you attempt to 'get' the first or last word in the cell, and if you attempt to extract outside the range – ie if there are 9 words and you try and extract word 10.

Get the last Word from a cell

Function GetLastWord(The_Text As String)
' Get the last word from a cell
Dim stGotIt As String
'Extracts the LAST word from a text string
stGotIt = StrReverse(The_Text)
stGotIt = Left(stGotIt, InStr(1, stGotIt, " ", vbTextCompare))
GetLastWord = StrReverse(Trim(stGotIt))
End Function


The code is added as a user defined function, copied into the module / userform module you are working on. To use it on a worksheet, it is in the format of a formula: =Getlastword(a2) which will give you the last word from cell a2 in the cell you entered the formula. In VBA you will need to use: worksheetfunction.Getlastword(a2)

Moving some code across sheets – For intel new work allocation

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Worksheets("Report").Columns("A:F").ClearContents

With Sheets("Sheet2")
lastrowX = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

Worksheets("Sheet2").Select
Columns("D:F").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "Opening"
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C" & lastrowX).RemoveDuplicates Columns:=Array(1, 2, 3), _
Header:=xlYes
ActiveSheet.Range("E2") = "=COUNTIFS(Sheet2!D:D,Opening!A2,Sheet2!E:E,Opening!B2,Sheet2!F:F,Opening!C2)"

With Sheets("Opening")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E" & lastrow), Type:=xlFillDefault

Worksheets("Sheet2").Select
Columns("g:h").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "Type"
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C" & lastrowX).RemoveDuplicates Columns:=Array(1, 2), _
Header:=xlYes
ActiveSheet.Range("E2") = "=COUNTIFS(Sheet2!g:g,Type!A2,Sheet2!h:h,Type!b2)"

With Sheets("Type")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E" & lastrow), Type:=xlFillDefault

Worksheets("Sheet2").Select
Columns("m:n").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "Doors"
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C" & lastrowX).RemoveDuplicates Columns:=Array(1, 2), _
Header:=xlYes
ActiveSheet.Range("E2") = "=COUNTIFS(Sheet2!m:m,Doors!A2,Sheet2!n:n,Doors!b2)"

With Sheets("Doors")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E" & lastrow), Type:=xlFillDefault

Worksheets("Sheet2").Select
Columns("p:r").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste
ActiveSheet.Name = "Size"
Application.CutCopyMode = False
ActiveSheet.Range("$A$1:$C" & lastrowX).RemoveDuplicates Columns:=Array(1, 2, 3), _
Header:=xlYes
ActiveSheet.Range("E2") = "=COUNTIFS(Sheet2!p:p,Size!A2,Sheet2!q:q,Size!B2,Sheet2!r:r,Size!C2)"

With Sheets("Size")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Range("E2").Select
Selection.AutoFill Destination:=Range("E2:E" & lastrow), Type:=xlFillDefault

Worksheets("Report").Select
Range("C1") = "Report ran: " & Now()
Range("A3") = "Openings"

Worksheets("Opening").UsedRange.Copy
Worksheets("Report").Select
Range("A4").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

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

Worksheets("Report").Select
Range("A" & lastrow + 2) = "Type"

Worksheets("Type").UsedRange.Copy
Worksheets("Report").Select
Range("A" & lastrow + 3).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("E4") = "Total"
Range("E" & lastrow + 3) = "Total"

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

Worksheets("Report").Select
Range("A" & lastrow + 2) = "Doors"
Range("E" & lastrow + 3) = "Total"

Worksheets("Doors").UsedRange.Copy
Worksheets("Report").Select
Range("A" & lastrow + 3).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("E" & lastrow + 3) = "Total"

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

Worksheets("Report").Select
Range("A" & lastrow + 2) = "Size"
Range("E" & lastrow + 3) = "Total"

Worksheets("Size").UsedRange.Copy
Worksheets("Report").Select
Range("A" & lastrow + 3).Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Range("E" & lastrow + 3) = "Total"

Sheets("Report").Select
Columns("A:E").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.Size = 10
End With
Sheets(Array("Opening", "Type", "Doors", "Size")).Select
ActiveWindow.SelectedSheets.Delete

Sheets("Report").Select
Range("A1").Select

Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True

Userform functions and codes

2013 – Sumifs replacement and Unique value (.RemoveDuplicates equivalent process)

Sumproduct

Equivalent of SUMIFS in Excel 2010.

The above identifies A1 in the first column and C1 in the third column, adding all the values where both appear, in Col D.

Back to VBA

Sending data to a .txt file

Dim FileUser As String
Dim FileuserDocFILE As String

FileUser = ActiveWorkbook.Name

On Error Resume Next
MkDir "" & Worksheets("NJB").Range("C13")
FileuserDocFILE = "\\DataLink\Overnight\DataLink_Inc_Locations.txt" 'name the .txt database to hold the info
'On Error GoTo 0

'This section lets you choose the fields to go into the .txt database
'The Chr(9) allows a Tab to be included between the fields

Open FileuserDocFILE For Append As #1
Print #1, Main.IncPropertyname & Chr(9) & Main.Incpropertynumber & Chr(9) & Main.Incroadname & Chr(9) & "" & Chr(9) & "" & Chr(9) & "" & Chr(9) _
& Main.incpostcode & Chr(9) & Main.ClientRef & Chr(9) _
& Main.Incloctype & Chr(9) & Worksheets("Tabs").Range("B1") & Main.incpostcode & Chr(9) & Worksheets("Tabs").Range("A1")

Close #1

Populate listbox in userform from a list

Dim i As Long
For i = 1 To 25
Main.Increportedby.AddItem Sheets("MO_Codes").Range("a" & i).Value

Next i

Main.Increportedby.ListIndex = 0

VBA Delete worksheets but keep those specifically named

Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "Sheet1" And ws.Name <> "Sheet2" Then ws.Delete
Next
Application.DisplayAlerts = True

Formula to look at multiple columns on the same row and add up those that meet the criteria.

=SUMPRODUCT((A1:A7=1)*(B1:B7="Y"))

It always needs to be in the same range-size though (ie 1:7 in the example)

What colour is the cell (not Conditional formatting) ?

MsgBox ActiveCell.Interior.ColorIndex

Sub Button3_Click()
For n = 1 To 56
Worksheets("Sheet1").Range("A" & n) = n
Worksheets("Sheet1").Range("A" & n).Select
ActiveCell.Interior.ColorIndex = n
Next n
End Sub

'Loops through Copying cells over where the colour of the cell matches the test

'Set rows 2-20
'set cols 6 to 11
Application.ScreenUpdating = False

For r = 2 To 500
For c = 6 To 11

Cells(r, c).Select
x = Selection.Interior.ColorIndex

If x = 5 Then
ActiveSheet.Cells(r, c).Copy Worksheets("sheet3").Cells(r, c)
End If

Next c

Next r

MsgBox "done"

The next set of code compares the values on page 1 to page 2 and moves them to page 3 if matched
The 2nd part accounts for 2 columns matching

Sub Button1_Click()

With Sheets("sheet3")
lastrowD = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Sheets("Sheet3").Range("A2:Z" & lastrowD).ClearContents

With Sheets("sheet1")
lastrowA = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With Sheets("sheet2")
lastrowB = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

lastrowC = 2

For n = 2 To lastrowA

For p = 2 To lastrowB
x = Worksheets("Sheet1").Range("A" & n)
y = Worksheets("Sheet2").Range("A" & p)

If x = y Then
Worksheets("Sheet1").Range("A" & n).EntireRow.Copy Worksheets("Sheet3").Range("A" & lastrowC)
lastrowC = lastrowC + 1
End If

Next p

Next n

With Sheets("sheet3")
lastrowD = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add Key:=Range("A2:A" & lastrowD) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet3").Sort
.SetRange Range("A1:B" & lastrowD)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Sheets("Sheet3").Select

For n = 2 To lastrowD
Worksheets("Sheet3").Range("A" & n).Select
b = Worksheets("Sheet3").Range("A" & n + 1)
If Selection <> b Then
ActiveCell.Offset(1).EntireRow.Insert
n = n + 1
End If
Next n

End Sub

Sub Button2_Click()
With Sheets("sheet3")
lastrowD = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Sheets("Sheet3").Range("A2:Z" & lastrowD).ClearContents

With Sheets("sheet1")
lastrowA = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

With Sheets("sheet2")
lastrowB = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

lastrowC = 2

For n = 2 To lastrowA

For p = 2 To lastrowB
x = Worksheets("Sheet1").Range("A" & n) & Worksheets("sheet1").Range("C" & n)
y = Worksheets("Sheet2").Range("A" & p) & Worksheets("sheet2").Range("C" & p)

If x = y Then
Worksheets("Sheet1").Range("A" & n).EntireRow.Copy Worksheets("Sheet3").Range("A" & lastrowC)
lastrowC = lastrowC + 1
End If

Next p

Next n

With Sheets("sheet3")
lastrowD = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet3").Sort.SortFields.Add Key:=Range("A2:A" & lastrowD) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet3").Sort
.SetRange Range("A1:E" & lastrowD)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

Sheets("Sheet3").Select

For n = 2 To lastrowD
Worksheets("Sheet3").Range("A" & n).Select
b = Worksheets("Sheet3").Range("A" & n + 1)
If Selection <> b Then
ActiveCell.Offset(1).EntireRow.Insert
n = n + 1
End If
Next n
End Sub

Currency additions in Userforms – iBAT adding costs

Private Sub CommandButton1_Click()
MsgBox (CCur(TextBox1) + CCur(TextBox2)) * 5
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
TextBox1 = Format(TextBox1, "£#,##0.00")
End Sub

Datanology

Leave a Reply

Your email address will not be published. Required fields are marked *