Mis Tools‎ > ‎

Excel tips and VBA SUBs

Life of SCCM guy will be difficult without magic of Excel. So, here are some of my VBAs that I use.

 

Auto Run

Making your macros run automatically when opening your workbook. You can either use the Auto Open method or the Workbook Open method.
 

Active Cell

An active cell is the current cell that is selected. This term is used in many macros. This can be used as a marker. A good example is when you need to move from your current cell. Refer to Moving your cursor macro.
Adding Items to a combobox  
To add a combobox refer to User Form. To populate a combobox or a listbox is the same. You could add from the code or even from a range of cells in your spreadsheet. To add from the code, just add this line to your code.
ComboBox1.AddItem "Product A"
ComboBox1.AddItem "Product B"
 

Counting Rows & Columns & Sheets

Count all active rows in worksheet w/o header:

COUNT(sheet_name!1:65536)-1

or more robust VBA:

Sub CreateSummarySheet()
Dim sws As Worksheet, ws As Worksheet
Dim slr As Long
Dim Found As Boolean
Application.ScreenUpdating = False
On Error Resume Next
Set sws = Sheets("Summary")
sws.Cells.Clear
On Error GoTo 0
If sws Is Nothing Then
   Sheets.Add(Before:=Sheets(1)).Name = "Summary"
   Set sws = ActiveSheet
End If
' //add header
'With sws.Range("A1:B1")
'   .Value = Array("Worksheet", "Count")
'   .Font.Bold = True
'   .Font.Size = 11
'End With

For Each ws In Worksheets
   If ws.Name <> sws.Name And Not LCase(ws.Name) Like "table of content*" Then
      If ws.UsedRange.Rows.Count > 1 Then
         Found = True
         sws.Range("A" & Rows.Count).End(3)(2).Value = ws.Name
         sws.Range("B" & Rows.Count).End(3)(2).Value = ws.UsedRange.Rows.Count - 1 ' //w/o header
         'sws.Range("C" & Columns.Count).End(3)(2).Value = ws.UsedRange.Columns.Count  '//count columns,
      End If
   End If
Next ws
'//add total of all rows count
'If Found Then
 '  slr = sws.Cells(Rows.Count, 1).End(xlUp).Row
  ' With sws.Range("A" & slr + 1 & ":B" & slr + 1)
   '   .Value = Array("Total", Application.Sum(sws.Columns(2)))
    '  .Font.Bold = True
  '    .Font.Size = 12
  ' End With
  ' sws.Columns.AutoFit
  ' sws.Range("A1").CurrentRegion.Borders.Color = vbBlack
' End If
Application.ScreenUpdating = True
End Sub


When you have selected a range, it is sometimes useful to know how many rows or columns you have selected as this information can be used in your macros (for eg when you have reached the end, you will know it is time to stop the macros. This macro will do the trick.
Sub Count()
myCount = Selection.Rows.Count    'Change Rows to Columns to count columns
MsgBox myCount
End Sub
The next macro counts the number of sheets instead. Refer to Protecting all sheets macro which uses this method.
Sub Count2()
myCount = Application.Sheets.Count
MsgBox myCount
End Sub

Carriage Return

Sometimes you may want to put a line of text on the next row and not let it continue on the first row. See this example in a message box.
Sub TwoLines()
MsgBox "Line 1" &  vbCrLf & "Line 2"
End Sub

Close All Files

Sometimes you may want to close all files without saving. Doing it manually is a hassle with the question "Do you wanna save?"
Sub CloseAll()
Application.DisplayAlerts = False
myTotal = Workbooks.Count
For i = 1 To myTotal
    ActiveWorkbook.Close
Next i
End Sub

Copying A Range

Copy data from a specific range can be done with this macro. Here data is copied from the current sheet to the activecell.
Sub CopyRange()
Range("A1:A3").Copy Destination:=ActiveCell
End Sub
To copy from a range in another sheet (eg Sheet3) to the active cell you need to change the code to;
Sheets("sheet3").Range("A1:A3").Copy Destination:=ActiveCell

Counter

To use a counter in your macro, just assign any cell to retain the value. In this example the cell A1 is chosen. Each time the macro is run, it adds the value 1 to the cell A1.
           
Sub Count()
 mycount = Range("a1") + 1
 Range("a1") = mycount
End Sub

Current Date

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean,  Cancel As Boolean)
Range("A1") = Now        'Select any cell you want
End Sub

Current Cell Content

To know what the cell contains ie dates, text or formulas before taking a course of action. In this example a message box is displayed. Replace this with a macro should you require another course of action.
Sub ContentChk()
If Application.IsText(ActiveCell) = True Then
MsgBox "Text"             'replace this line with your macro
Else
If ActiveCell = "" Then
MsgBox "Blank cell"    'replace this line with your macro
Else
End If
If ActiveCell.HasFormula Then
MsgBox "formula"         'replace this line with your macro
Else
End If
If IsDate(ActiveCell.Value) = True Then
MsgBox "date"               'replace this line with your macro
Else
End If
End If
End Sub

Current Cell Position and Value

Sometimes we need to know the current cell position. This would do the trick.
Sub CellActivePositionValue()
myRow = ActiveCell.Row
myCol = ActiveCell.Column
MyCellValue = ActiveCell.Value
MsgBox myRow & "," & myCol & "," & MyCellValue
End Sub

 Deleting Empty Rows

To delete empty rows in a selected range we can use the following macro. The macro here uses the For Next Loop. First the macro counts the rows in a selected range to determine the when the macro should stop. The For Next statement acts as a counter.
Sub DelEmptyRow()
Rng = Selection.Rows.Count
ActiveCell.Offset(0, 0).Select
Application.ScreenUpdating = False
For i = 1 To Rng
If ActiveCell.Value = "" Then    'You can replace "" with 0 to delete rows with 'the value zero
Selection.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Next i
Application.ScreenUpdating = True
End Sub
The statement "Application.ScreenUpdating = False" prevents the screen from updating to ensure the macro runs faster and the screen will not flicker. Don't forget to set it back to "True".

Deleting Range Names 

To delete all the range names in your workbook, this macro will do the trick.
Sub DeleteNames()
Dim NameX As Name
For Each NameX In Names
ActiveWorkbook.Names(NameX.Name).Delete
Next NameX
End Sub

 Find Matches in two columns  

Sub Find_MatchesInTwoCol()
Dim CompareRange As Variant, x As Variant, y As Variant
' Usage: Leav Colum B empty 
' Set CompareRange equal to the range to which you will compare the selection.
 Set CompareRange = Range("C1:C5") '<== set range here
' NOTE: If the compare range is located on another workbook  or worksheet, use the following syntax.
' Set CompareRange = Workbooks("Book2").Worksheets("Sheet2").Range("C1:C5")
' Loop through each cell in the selection and compare it to each cell in CompareRange.

For Each x In Selection
    For Each y In CompareRange
        If x = y Then x.Offset(0, 1) = x
     Next y
 Next x
End Sub

Duplicates

If you need to delete duplicate data in your worksheet that are in same column. This macro does the trick.
Public Sub DeleteDuplicateRows()
' This macro will delete all duplicate rows which reside under
' the first occurrence of the row.
' Use the macro by selecting a column to check for duplicates
' and then run the macro and all duplicates will be deleted, leaving
' the first occurrence only.
Dim R As Long
Dim N As Long
Dim V As Variant
Dim Rng As Range
On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set Rng = Application.Intersect(ActiveSheet.UsedRange, _
                    ActiveSheet.Columns(ActiveCell.Column))
Application.StatusBar = "Processing Row: " & Format(Rng.Row, "#,##0")
N = 0
For R = Rng.Rows.Count To 2 Step -1
If R Mod 500 = 0 Then
    Application.StatusBar = "Processing Row: " & Format(R, "#,##0")
End If
V = Rng.Cells(R, 1).Value
If V = vbNullString Then
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), vbNullString) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
Else
    If Application.WorksheetFunction.CountIf(Rng.Columns(1), V) > 1 Then
        Rng.Rows(R).EntireRow.Delete
        N = N + 1
    End If
End If
Next R
EndMacro:
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Duplicate Rows Deleted: " & CStr(N)
End Sub

 

 How to Highligh duplicate


Select the cells that you want to highlight. Under the Home tab, under Styles, Click Conditional Formatting. Go to Highlight Cell Rules and Click Duplicate Values.

How to remove duplicates in same colon in Excel?

Select the row or column that has duplicates that you would like to remove.
Go to Data -> Filter -> Advanced Filter, and type : $A$1:$A$17
Make sure the range is correct and check the option “unique records only“.

 How to use VLOOKUP to find missing SCCM clients

Copy in column A client to look for, and make this formula on column B:
 

B=VLOOKUP(A1,SCCMClients!$A$2:$A$21460,1,FALSE)


How to found duplicate in two columns?

1.      Put data in column A, and C, leave B empty. Type the following formula in cell B1:


=IF(ISERROR(MATCH(A1,$C$1:$C$XY,0)),"",A1)  


- make sure you put the last row values for the XY.

 

2.      On B1 cell, click Fill Down, and duplicates will show up in B column if they exist.

 How to find unique records in two columns?

To get unique record from Column A use this formula:

  =IF(COUNTIF(B:B,A2)=0,A2,"") 

or to get unique record from column B :

  =IF(COUNTIF(A:A,B2)=0,B2,"")

How to find duplicated records in a column?

=IF(COUNTIF($A$2:A2,A2)>1, "duplicate","")

How to find common records in a multiple column?

=IF(COUNTIF($A$2:$A$14,B7)>0,B7,"")

To email your current workbook the following code.

 
Sub Email()
ActiveWorkbook.SendMail recipients:="neven@NTCenter.com"
End SubTo Launch Program whitin Excel
 
Type in CELL: = HYPERLINK("file:///c:\WINDOWS\system32\CALC.exe","CALC")
Note, if you need to run a program with switches or arguments, then you need to create the CMD batch file since it can't be passed directly in the hyperlink.
OR

Run external program with VBA Shell function  

 
Sub SUMO1()
Q = MsgBox("RUN SUMO Check?", vbYesNo, "Running SUMO, please wait...")
If Q = vbNo Then
MsgBox "Exiting..."
Else
FileToLaunch = "C:\Exxon\QA\SUMO\sumocheck-2.vbs"
CMD_ARG = "TORSCC02 /htmllog:TORSCC01_SUMO_Report.html /IE"
programPath = "cscript.exe"
Shell programPath + " " + FileToLaunch + " " + CMD_ARG, vbNormalFocus
End If
End Sub