VBA / Macros

From Wiki
Jump to: navigation, search

Visit the setup page if you are not familiar with how to setup scripts
Macro Setup Instructions

Tips:

- You can combine most of the VBA code below into one subroutine.
- Remember to only have one Sub Name() End Sub per script.
- Code listed without the Sub isn't usually run by itself, but can be by just adding the subroutine syntax.

Refresh Connections

Assign to a button or insert before additional code to refresh outside connections to data tables

Sub REFRESH()
   ThisWorkbook.RefreshAll
End Sub

Refresh Query Table, then Pivot Table

Sub REFRESH()
   Sheets("sheetname").Range("A2").ListObject.QueryTable.REFRESH BackgroundQuery:=False
   Sheets("sheetname").PivotTables("pivottablename").PivotCache.REFRESH
End Sub

Auto Reapply Table Filter

Tables do not refresh the filter without "reapplying". This will auto-run the filter again.
Filter your table to exclude rows you do not want. Then add vba to worksheet's code.

Private Sub Worksheet_Activate()
    ActiveSheet.ListObjects("Table1").AutoFilter.ApplyFilter
End Sub

Run Macro in Background

Sub whatever()
Application.ScreenUpdating = False
' Place code here
Application.ScreenUpdating = True
End Sub

Run Macro Every X Minutes

Sub MyMacro()
      'Place your macro code here
      Application.OnTime Now + TimeValue("00:15:00"), "MyMacro" 
End Sub

Remove Trailing Space

Macro selects cells A2:A10 and removes any spaces after text

Sub NoSpaces()
   Sheets("WorksheetName").Select
   Range("A2:A100").Select
 Dim a As Range
  For Each a In Selection.Cells
   a = Trim(a) Next
End Sub

Count Tab Amount in Cell

Fill down the formula: =PROFEXIndentLevel(A1)

Function PROFEXIndentLevel(Cell As Range)
    'This function returns the indentation of a cell content
    
    Application.Volatile
    'With "Application.Volatile" you can make sure, that the function will be recalculated once the worksheet is recalculated
    'for example, when you press F9 (Windows) or press enter in a cell
    
    PROFEXIndentLevel = Cell.IndentLevel
    'Return the IndentLevel
    
End Function

http://professor-excel.com/how-to-return-the-indentation-of-a-cell-in-excel/

Add Data to Bottom of Table

Create an input worksheet and button (tied to vba) that will push 1 row (or cell) of data to the last row of a table.

Sub AddAcctValue()
Dim the_sheet As Worksheet
Dim table_list_object As ListObject
Dim table_object_row As ListRow

' Edit ("SheetName") to your table's worksheet name
      Set the_sheet = Sheets("SheetName")
      Set table_list_object = the_sheet.ListObjects(1)
      Set table_object_row = table_list_object.ListRows.Add

' "A" is the starting column of your table
      last_row_with_data = Range("A" & Rows.Count).End(xlUp).Row
      last_row_with_data = last_row_with_data

' ADDS DATA - to first column in table
      table_object_row.Range(1, 1).Value = "12/31/2016"

' ADDS DATA - to any additional columns
'  Example 1: Specify a cell to reference for data (on same sheet)
'  Example 2: Specify a cell to reference for data (on different sheet)
'  Example 3: Hardcode your value
      the_sheet.Range("B" & last_row_with_data) = Range("A50")
      the_sheet.Range("C" & last_row_with_data) = Worksheets("Sheet1").Range("A1")
      the_sheet.Range("D" & last_row_with_data) = "25"

' Note: If you have more than 1 table in the worksheet, you may need to adjust the ListObject number

End Sub

Multi-Row Add
Assumes Sheet1(A1:D3) have input data and SheetName(A1) is your table

Sub AddAcctValue()
Dim the_sheet As Worksheet
Dim table_list_object As ListObject
Dim table_object_row As ListRow

' Edit ("SheetName") to your worksheet name
Set the_sheet = Sheets("SheetName")
Set table_list_object = the_sheet.ListObjects(1)
Set table_object_row = table_list_object.ListRows.Add

' "A" is the starting column of your table
last_row_with_data = Range("A" & Rows.Count).End(xlUp).Row
last_row_with_data = last_row_with_data

' ADDS DATA - FIRST ROW OF DATA
table_object_row.Range(1, 1).Value = Worksheets("Sheet1").Range("A1")
the_sheet.Range("B" & last_row_with_data) = Worksheets("Sheet1").Range("B1")
the_sheet.Range("C" & last_row_with_data) = Worksheets("Sheet1").Range("C1")
the_sheet.Range("D" & last_row_with_data) = Worksheets("Sheet1").Range("D1")

' MULTI ROW ADD - SECOND ROW OF DATA
last_row_with_data2 = Range("A" & Rows.Count).End(xlUp).Row
last_row_with_data2 = last_row_with_data2 + 1

table_object_row.Range(2, 1).Value = Worksheets("Sheet1").Range("A2")
the_sheet.Range("B" & last_row_with_data2) = Worksheets("Sheet1").Range("B2")
the_sheet.Range("C" & last_row_with_data2) = Worksheets("Sheet1").Range("C2")
the_sheet.Range("D" & last_row_with_data2) = Worksheets("Sheet1").Range("D2")

' MULTI ROW ADD - 3RD ROW OF DATA
last_row_with_data3 = Range("A" & Rows.Count).End(xlUp).Row
last_row_with_data3 = last_row_with_data3 + 1

table_object_row.Range(3, 1).Value = Worksheets("Sheet1").Range("A3")
the_sheet.Range("B" & last_row_with_data3) = Worksheets("Sheet1").Range("B3")
the_sheet.Range("C" & last_row_with_data3) = Worksheets("Sheet1").Range("C3")
the_sheet.Range("D" & last_row_with_data3) = Worksheets("Sheet1").Range("D3")

End Sub

The code should really be changed to loop on its own.

Add Row to Bottom of Table

Sub Insert_New_Rows()
    Dim Lr As Integer
 
    Lr = Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
    Rows(Lr + 0).Insert Shift:=xlDown 'Inserting new row - change to + 1 if there isn't a total row at bottom
    Rows(Lr - 1).Copy 'Copying format of last row, before total row
    Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
    Application.CutCopyMode = False 'Deactivating copy mode
End Sub



Add Multiple Rows

Sub Insert_New_Rows()
    Let x = 0
    Do While x < Range("B5").Value 'Cell B5 indicates how many rows to add. Can remove lookup and hard code to number.
    Dim Lr As Integer
    Lr = Range("A" & Rows.Count).End(xlUp).Row 'Searching last row in column A
    Rows(Lr + 0).Insert Shift:=xlDown 'Inserting new row - change to + 1 if there isn't a total row at bottom
    Rows(Lr - 1).Copy 'Copying format of last row
    Rows(Lr + 1).PasteSpecial Paste:=xlPasteFormats 'Pasting format to new row
    Application.CutCopyMode = False 'Deactivating copy mode
    x = x + 1
    Loop
End Sub

Rename Files with an Excel List

  • Open local folder with files and highlight copy
  • Paste Special, file names (as text) in Column A
  • Enter desired file names in Column B
  • Column B will need to end with a file extension.
* Hint: Use a CONCATENATE formula on another worksheet to get the desired file names
  • Add vba to spreadsheet and change file path to location of files (make sure you add the \ at end of file name)
Sub RenameFiles()
'Modify as needed but keep trailing backslash
     Const strPath = "F:\path\FilesLocation\"
  Dim r As Long
  Dim n As Long
  n = Cells(Rows.Count, 1).End(xlUp).Row
  For r = 2 To n
  Name strPath & Cells(r, 1) As strPath & Cells(r, 2)
  Next r
End Sub

Combine Multiple CSV Files + Add Filename to Column A

Public Sub ImportAllCSV()

    Dim FName As Variant, r As Long
    Dim destCell As Range
    Dim csvFolder As String
    
    csvFolder = ThisWorkbook.Path & "\CSV FILES SUBFOLDER\"    'CHANGE THIS FOLDER PATH
    If Right(csvFolder, 1) <> "\" Then csvFolder = csvFolder & "\"
    
    With ActiveSheet
        r = .UsedRange.Row + .UsedRange.Rows.Count
        Set destCell = .Cells(r, "B")
    End With
    
    FName = Dir(csvFolder & "*.csv")
    Do While FName <> ""
        r = ImportCsvFile(csvFolder & FName, destCell)
        destCell.Offset(0, -1).Resize(r, 1).Value = FName
        Set destCell = destCell.Offset(r, 0)
        FName = Dir
    Loop
    
End Sub
Private Function ImportCsvFile(FileName As String, Position As Range) As Long
    With Position.Parent.QueryTables.Add(Connection:="TEXT;" & FileName, Destination:=Position)
        .Name = Replace(FileName, ".csv", "")
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = False
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = xlMacintosh
        .TextFileStartRow = 2
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileOtherDelimiter = ";"
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .Refresh BackgroundQuery:=False
        ImportCsvFile = .ResultRange.Rows.Count
        .Delete
    End With
End Function

Run Macro on Hidden Worksheets

The script unhides the worksheet and runs your macro without displaying the worksheet to the user.
Example assumes that Sheet 2 is hidden.

Sub MacroName()
Application.ScreenUpdating = False
'note that if you're stepping through your code, screenupdating will be true anyway
'unhide the sheet you want to work with
Sheets("sheet2").Visible = True
‘COPY YOUR MACRO CODE TO HERE
'Hides the sheet again
Sheets("sheet2").Visible = False
'Turns screenupdating back on, or Excel will be useless
Application.ScreenUpdating = True
End Sub


Message Box Examples

Add Message Box Popup

Add any of these lines to the end of your script/macro

'One Message Line 
MsgBox "This is fun" 
'Message includes a value 
MsgBox "Entered value is " & Range("A1").Value 
'Two Lines of Message 
MsgBox "Line 1" & vbNewLine & "Line 2"

If Range Contains X

Private Sub Find_Criteria() 
                                 'or use: Sub Worksheet_Change(ByVal Target As Range)'
Dim i As Variant     
Dim FindRange As Range 
Set FindRange = Range("A1:K50")  'range you are searching'
For Each i In FindRange 
If i = "criteria" Then           'or formula: i < 0'
MsgBox "Found" & " " & i.Address 'i.Address is cell row/column. Use: i.row or i.column'
                                 'Add line break "Line 1" & vbNewLine & "Line 2" 
End If 
Next i 
End Sub


Copy & Paste Table

VBA will copy and paste a table. This can be helpful if you need a temporary table to run code on to prevent modifying the original source.

Sub CopyTable()
Range("Table1[#All]").Copy Destination:=Worksheets("2010").Range("A13")
End Sub

Copy Filtered Table

Sub CopyFilteredTable() 
Dim rng As Range 
Dim WS As Worksheet 
For Each Row In Range("Table2[#All]").Rows 
If Row.EntireRow.Hidden = False Then 
If rng Is Nothing Then Set rng = Row 
Set rng = Union(Row, rng) 
End If 
Next Row 
Set WS = Sheets.Add 
rng.Copy Destination:=WS.Range("A1") 
End Sub

Printing

Print All Worksheets
Worksheets.PrintOut
Print All Charts
Charts.PrintOut
Print Whole Workbook
ActiveWorkbook.PrintOut
Print this workbook which the VBA code in
ThisWorkbook.PrintOut
Print a Specific Sheet
Sheets("Sheet2").PrintOut
Print the Active Sheet
ActiveSheet.PrintOut
Print Selected Sheets
ActiveWindow.SelectedSheets.PrintOut
Print Selection
Selection.PrintOut
Print A Range
Range("A1:C6").PrintOut</code>

Extract Slicer Selection to Cell

Add this VBA first (no edit needed)

Public Function GetSelectedSlicerItems(SlicerName As String) As String
    Dim oSc As SlicerCache
    Dim oSi As SlicerItem
    Dim lCt As Long
    On Error Resume Next
    Application.Volatile
    Set oSc = ThisWorkbook.SlicerCaches(SlicerName)
    If Not oSc Is Nothing Then
        For Each oSi In oSc.SlicerItems
            If oSi.Selected Then
                GetSelectedSlicerItems = GetSelectedSlicerItems & oSi.Name & ", "
                lCt = lCt + 1
            ElseIf oSi.HasData = False Then
                lCt = lCt + 1
            End If
        Next
        If Len(GetSelectedSlicerItems) > 0 Then
            If lCt = oSc.SlicerItems.Count Then
                GetSelectedSlicerItems = "All Items"
            Else
                GetSelectedSlicerItems = Left(GetSelectedSlicerItems, Len(GetSelectedSlicerItems) - 2)
            End If
        Else
            GetSelectedSlicerItems = "No items selected"
        End If
    Else
        GetSelectedSlicerItems = "No slicer with name '" & SlicerName & "' was found"
    End If End Function


In the cell you want to show value
=GetSelectedSlicerItems("Slicer_name")

Slicer name can be found by right-click slicer and select slicer settings
Name to use in formulas line

http://www.jkp-ads.com/Articles/slicers05.asp

Hide Columns With No Data (Button Trigger)

Looks for a 0 or blank in range, then hides full column
Doesn't trigger on change

Sub HideRows()     
    Application.ScreenUpdating = False
    Dim c As Range
    For Each c In Range("E1:AW1")
        c.EntireColumn.Hidden = (c.Value = 0)
    Next c
    Application.ScreenUpdating = True
End Sub

Hide Columns with No Data (Updated Triggered)

When the pivot table in a worksheet is updated, the script is triggered
Only one pivot table can be on this worksheet

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
' Hides unused columns after pivot table change
    Application.ScreenUpdating = False
    Dim c As Range
    
' Look in this range for 0 or blank cell
    For Each c In Range("J23:Z23")
        c.EntireColumn.Hidden = (c.Value = 0)
    Next c
    Application.ScreenUpdating = True
End Sub

Autofit Columns/Row

' Autofit Column
Worksheets("Sheet1").Range("A:E").Columns.AutoFit

' Autofit Row
Worksheets("Sheet1").Columns("A1:A20").AutoFit

Filter Table on Cell

Filters a column in table by another cell's value

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    ' SET CELL that will trigger table change
      Set KeyCells = Range("B17")
    
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
           Is Nothing Then
    
    ' .ListObjects("TableName")
    ' .Field:=tablecolumn#
    ' Cells(Row#TriggerCell, Column#TriggerCell)
    
        ActiveSheet.ListObjects("eMacctsname").Range.AutoFilter Field:=2, Criteria1:="=" & Cells(17, 2)
               
    End If
End Sub