Create a table with a macro - excel

I have this simple range:
I want to create a macro which creates a table from a range. The macro I get is this:
Sub Macro1()
'
' Macro1 Macro
'
'
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$B$3"), , xlYes).Name = _
"Table12"
ActiveCell.Range("Table12[#All]").Select
End Sub
The problem is that I want the macro to not be contingent on a specific size. I for instance want it to be able to work with this table as range aswell:
The problem in the code seems that it uses "$A$1:$B$3" but it should be independent of that. Is there a simple way to fix this? How can I record the macro so that it works for all tables?

The next piece of code will create a table ("MyTable") starting from the active cell to the adjacent most right column and to the down filled row of active cell column:
Sub TableRightDownOfSelection()
Dim rnG As Range
UnlistIt
Set rnG = Range(ActiveCell.Address & ":" & Cells(Cells(Rows.count, _
ActiveCell.Column).End(xlUp).Row, ActiveCell.End(xlToRight).Column).Address)
ActiveSheet.ListObjects.Add(xlSrcRange, rnG, , xlYes).Name = "MyTable"
End Sub
Sub UnlistIt()
On Error Resume Next
ActiveSheet.ListObjects("Table1").Unlist
If Err.Number > 0 Then Err.Clear
On Error GoTo 0
End Sub
In order to avoid an error message, in case you try the code again, the UnlistIt Sub will be called before creating the table...

You could use the currentregion property
Sub CreateTbl()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rg As Range
Set rg = ws.Range("A1").CurrentRegion
ws.ListObjects.Add(xlSrcRange, rg, , xlYes).Name = "myTable"
End Sub
But be aware this code will create a table named like myTable_1 in case you already have a table namend myTable somewhere else and it will faill if you run it twice for the same range.
Addition: Based on the comments one could try to use the active cell
Sub CreateTbl()
Dim ws As Worksheet
Dim rg As Range
Set rg = ActiveCell.CurrentRegion
Set ws = rg.Parent
ws.ListObjects.Add(xlSrcRange, rg, , xlYes).Name = "myTable"
End Sub

Related

Dynamically storing a cell reference as a variable in VBA to then select (and delete) a range using the variable stored

I currently have a VBA macro that turns a regular data extract into a table. In the macro I have defined a range which is large enough to exceed the number of rows typically extracted.
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$AG$20000"), , xlYes).Name _
= "Table1"
My macro then does some other transformation/addition of formulas etc to the table, and the table is then presented via PowerBI.
I want to delete the excess rows in the table - which varies for each extract.
In the example below - which has recorded the desired sequence of steps, there are only 186 rows.
Range("Table1[[#Headers],[Client Id]]").Select
Selection.End(xlDown).Select
Range("A187").Select
Range(Selection, Selection.End(xlDown)).Select
Rows("187:20000").Select
Selection.Delete Shift:=xlUp
I want to store the range ("A187") as a variable
I then want to insert the stored variable in the selection 187:20000
Alternatively, if I could do a variabilised selection of the range I want to turn into a table, that would work too.
Any help would be appreciated.
The following will create a table to fit the data assuming there are no extra data cells:
ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion, , xlYes).Name = "Table1"
If you need to force columns to include "A:AG" only use:
ActiveSheet.ListObjects.Add(xlSrcRange, Range("A1").CurrentRegion.Columns("A:AG"), , xlYes).Name = "Table1"
ActiveSheet.ListObjects.Add(...).Name = "Table1" is how a recorded macro would create the table. To avoid naming conflict, I would avoid using the generic Table1 as a name.
If the name isn't important use:
ActiveSheet.ListObjects.Add xlSrcRange, Range("A1").CurrentRegion.Columns("A:AG"), , xlYes
If there is only one Table on the woksheet, you can refer to it as:
ActiveSheet.ListObjects(1)
Delete Empty Bottom Rows (Applied to an Excel Table (ListObject))
Sub DeleteEmptyBottomRowsTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim tbl As ListObject: Set tbl = ws.ListObjects("Table1")
' Remove possible filters.
' The Find method will fail if the table is filtered.
If tbl.ShowAutoFilter Then
If tbl.AutoFilter.FilterMode Then tbl.AutoFilter.ShowAllData
End If
Dim rg As Range: Set rg = tbl.DataBodyRange
If rg Is Nothing Then Exit Sub
DeleteEmptyBottomRows rg
End Sub
Sub DeleteEmptyBottomRows(ByVal rg As Range)
Dim lCell As Range
Set lCell = rg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then rg.Delete xlShiftUp: Exit Sub
Dim rOffset As Long: rOffset = lCell.Row - rg.Row + 1
Dim rCount As Long: rCount = rg.Rows.Count
If rOffset = rCount Then Exit Sub
Dim rResize As Long: rResize = rCount - rOffset
rg.Resize(rResize).Offset(rOffset).Delete xlShiftUp
End Sub

Receiving Error when trying to run macro on multiple sheets using VBA

I have the below macro that should be running on each sheet in my workbook. When I run this code, I am getting the following error: 'A table cannot overlap another table' and it is highlighting this line:
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$I"), , xlYes).Name = _
"Table1"
Is this because I applied the macro to table one and now it cannot be applied to the other tables?
All sheets have the same column headers but different number of rows (not sure if that matters). Essentially all I am trying to do is get rid of the index, format the data into a table, extend the column lengths to fit all the column names, and rename the columns.
Another thing to note, there are about 170 sheets that this macro needs to run through.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call CreateTables(ws)
Next
End Sub
Sub CreateTables(ws As Worksheet)
'
' CreateTables Macro
'
' Keyboard Shortcut: Ctrl+Shift+S
'
With ws
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("A:I").Select
Application.CutCopyMode = False
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A:$I"), , xlYes).Name = _
"Table1"
Columns("A:I").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight1"
Columns("A:I").EntireColumn.AutoFit
Range("Table1[[#Headers],[Tier2_ID]]").Select
ActiveCell.FormulaR1C1 = "Community ID"
Range("Table1[[#Headers],[Tier2_Name]]").Select
ActiveCell.FormulaR1C1 = "Community Name"
Range("Table1[[#Headers],[Current_MBI]]").Select
ActiveCell.FormulaR1C1 = "Current MBI"
Range("Table1[[#Headers],[countMBI]]").Select
ActiveCell.FormulaR1C1 = "Cout"
Range("Table1[[#Headers],[Cout]]").Select
ActiveCell.FormulaR1C1 = "Count"
Range("Table1[[#Headers],[TotalEDVisits]]").Select
ActiveCell.FormulaR1C1 = "Total ED Visits"
Range("Table1[[#Headers],[EDtoIPTotal]]").Select
ActiveCell.FormulaR1C1 = "Total ED to Inpatient"
Range("Table1[[#Headers],[totalSev1to3]]").Select
ActiveCell.FormulaR1C1 = "Severity 1 to 3"
Range("Table1[[#Headers],[totalSev4to6]]").Select
ActiveCell.FormulaR1C1 = "Severity 4 to 6"
Range("Table1[[#Headers],[totalPaid]]").Select
ActiveCell.FormulaR1C1 = "Total Paid"
Range("L22").Select
End With
End Sub
Convert Ranges to Tables
The table names in a workbook have to be unique.
This code (re)names each table sequentially i.e. Table1, Table2, Table3....
This is a one-time operation code, so test it first on a copy of your workbook.
If (when) you're satisfied with the outcome, run it in your original workbook.
Now the code is no longer needed (useless).
If you really need to select the cell L22 on each worksheet, you have to make sure the workbook is active (in the first code use If Not wb Is ActiveWorkbook Then wb.Activate).
In the second code, you can then use Application.Goto ws.Range("L22") right before (above) the last 'Else.
Sub ConvertToTables()
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet
Dim n As Long
For Each ws In wb.Worksheets
n = n + 1 ' to create Table1, Table2, Table3...
ConvertToTable ws, "Table", n
Next
End Sub
Sub ConvertToTable( _
ByVal ws As Worksheet, _
ByVal TableBaseName As String, _
ByVal TableIndex As Long)
'
' CreateTables Macro
'
' Keyboard Shortcut: Ctrl+Shift+S
'
' Note that all column names have to be unique i.e. you cannot
' rename the 'countMBI' column to 'Cout' before the existing 'Cout' column
' has been renamed.
Const OldColsList As String _
= "Tier2_ID,Tier2_Name,Current_MBI,Cout," _
& "countMBI,TotalEDVisits,EDtoIPTotal,totalSev1to3," _
& "totalSev4to6,totalPaid"
Const NewColsList As String _
= "Community ID,Community Name,Current MBI,Count," _
& "Cout,Total ED Visits,Total ED to Inpatient,Severity 1 to 3," _
& "Severity 4 to 6,Total Paid"
Const FirstCellAddress As String = "A1"
' Reference the first cell ('fCell').
Dim fCell As Range: Set fCell = ws.Range(FirstCellAddress)
' Check if the first cell is part of a table ('tbl').
' A weak check whether the table has already been created.
Dim tbl As ListObject: Set tbl = fCell.ListObject
If tbl Is Nothing Then ' the first cell is not part of a table
' Reference the range ('rg').
Dim rg As Range: Set rg = fCell.CurrentRegion
' Delete the first column. Note that the range has shrinked by a column.
rg.Columns(1).Delete xlShiftToLeft
' Convert the range to a table ('tbl').
Set tbl = ws.ListObjects.Add(xlSrcRange, rg, , xlYes)
With tbl
.Name = TableBaseName & CStr(TableIndex)
.TableStyle = "TableStyleLight1"
' Write the lists to string arrays ('OldCols', 'NewCols')
Dim OldCols() As String: OldCols = Split(OldColsList, ",")
Dim NewCols() As String: NewCols = Split(NewColsList, ",")
Dim lc As ListColumn
Dim n As Long
' Loop through the elements of the arrays...
For n = 0 To UBound(OldCols)
' Attempt to reference a table column by its old name.
On Error Resume Next
Set lc = .ListColumns(OldCols(n))
On Error GoTo 0
' Check if the column reference has been created.
If Not lc Is Nothing Then ' the column exists
lc.Name = NewCols(n) ' rename the column
Set lc = Nothing ' reset to reuse in the next iteration
'Else ' the column doesn't exist; do nothing
End If
Next n
' The columns should be autofitted after their renaming.
.Range.EntireColumn.AutoFit
End With
'Else ' the first cell is part of a table; do nothing
End If
End Sub

Copy and paste values only after filtering data in vba [duplicate]

I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.
Name of the data sheet : Data
Name of the filtered Sheet : Hoky
I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.
My problems are:
The number of rows is different everytime. (manual effort)
Columns are not in order.
Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"
'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste
Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste
End Sub
Best way of doing it
Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.
Sub selectVisibleRange()
Dim DbExtract, DuplicateRecords As Worksheet
Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")
DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
DuplicateRecords.Cells(1, 1).PasteSpecial
End Sub
I suggest you do it a different way.
In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is "hockey" and if yes I insert the values in the other sheet one by one, by using Offset.
I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification
Sub TestThat()
'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long
'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")
Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
'I went from the cell row3/column6 (or F3) and go down until the last non empty cell
i = 2
For Each rCell In SportsRange 'loop through each cell in the range
If rCell = "hockey" Then 'check if the cell is equal to "hockey"
i = i + 1 'Row number (+1 everytime I found another "hockey")
HokySh.Cells(i, 2) = i - 2 'S No.
HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age
End If
Next rCell
End Sub
When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).
Example:
Sub copy()
'source worksheet
dim ws as Worksheet
set ws = Application.Worksheets("Data")' set you source worksheet here
dim data_end_row_number as Integer
data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
'enable filter
ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
Application.Worksheets("Hoky").Range("B3").Paste
'You have to add headers to Hoky worksheet
end sub
it needs to be .Row.count not Row.Number?
That's what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets("Export (2)") 'Data Source
LastRow = Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A2:AB" & LastRow).SpecialCells(xlCellTypeVisible).Copy

Create a pivot table in a predefined location

I'm trying to create a pivot table and place it in a predefined location (not a new sheet).
Before running the macro each time, the pivot table is deleted and also the predefined sheet.
I noticed that when you create a table manually, the table name increases by one each time (PivotTable2, PivotTable3...), which I think is where my code is falling down.
I get a Run-time error 5, invalid procedure call or argument on this line:
ActiveWorkbook.PivotCaches.Create
I did check out this thread, which says that you can remove the table name parameter completely, or rename it - however I still get errors.
My code:
Sub CreatePivot()'
' CreatePivot Macro
'
' Set data as table
Sheets("Filtered Flags").Select
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$G$16000"), , xlYes).Name _
= "Table1"
' Create worksheet for pivot output
Sheets.Add Before:=ActiveSheet
ActiveSheet.Name = "Flag Pivot"
'Create Pivot Table
Sheets("Filtered Flags").Select
Range("Table1[[#Headers],[Order '#]]").Select
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Table1", Version:=6).CreatePivotTable TableDestination:="Flag Pivot!R3C1" _
, TableName:="PivotTable5", DefaultVersion:=6
Sheets("Flag Pivot").Select
Cells(3, 1).Select
With ActiveSheet.PivotTables("PivotTable5").PivotFields("Material #")
.Orientation = xlRowField
.Position = 1
End With
End Sub
So there's a few things to work with here. One of the basics to get started with (and to understand why some of my example below is constructed) is to learn about avoiding the use of Select and Activate. Also, always using Option Explicit will help you sidestep many problems in naming and using variables.
Option Explicit
Public Sub CreatePivot()
'--- establish some basic objects to use...
Dim flagsWS As Worksheet
Set flagsWS = ThisWorkbook.Sheets("Filtered Flags")
'--- now, define the range of cells that contain the data
' and create the pivot cache
With flagsWS
Dim lastRow As Long
Dim lastCol As Long
Dim dataArea As Range
Dim dataAreaString As String
lastRow = .Cells(.Cells.rows.count, 1).End(xlUp).Row
lastCol = .Cells(1, .Cells.Columns.count).End(xlToLeft).Column
Set dataArea = .Range(.Cells(1, 1), .Cells(lastRow, lastCol))
dataAreaString = .Name & "!" & dataArea.Address
Dim pCache As PivotCache
Set pCache = ThisWorkbook.PivotCaches.Create(SourceType:=xlDatabase, _
SourceData:=dataAreaString)
End With
'--- create or clear the sheet for our new pivot
Dim pivotWS As Worksheet
On Error Resume Next
Set pivotWS = ThisWorkbook.Sheets("Flag Pivot")
On Error GoTo 0
If Not pivotWS Is Nothing Then
'--- delete everything on the worksheet so we're starting clean
pivotWS.Cells.Clear
Else
Set pivotWS = ThisWorkbook.Sheets.Add
pivotWS.Name = "Flag Pivot"
End If
'--- finally create the pivot table
Dim flagPT As PivotTable
Set flagPT = pivotWS.PivotTables.Add(PivotCache:=pCache, _
TableDestination:=pivotWS.Range("A4"), _
TableName:="AnnasPivotTable")
End Sub

Remove Entire Row if Column Contains $0.00 Value [duplicate]

I have an excel workbook, in worksheet1 in Column A, IF the value of that column = ERR I want it to be deleted (the entire row), how is that possible?
PS: keep in mind that I have never used VBA or Macros before, so detailed description is much appreciated.
Using an autofilter either manually or with VBA (as below) is a very efficient way to remove rows
The code below
Works on the entire usedrange, ie will handle blanks
Can be readily adpated to other sheets by changing strSheets = Array(1, 4). ie this code currently runs on the first and fourth sheets
Option Explicit
Sub KillErr()
Dim ws As Worksheet
Dim lRow As Long
Dim lngCol As Long
Dim rng1 As Range
Dim strSheets()
Dim strws As Variant
strSheets = Array(1, 4)
For Each strws In strSheets
Set ws = Sheets(strws)
lRow = ws.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
lngCol = ws.Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
Application.ScreenUpdating = False
ws.Rows(1).Insert
Set rng1 = ws.Range(ws.Cells(1, lngCol), ws.Cells(lRow + 1, lngCol))
With rng1.Offset(0, 1)
.FormulaR1C1 = "=RC1=""ERR"""
.AutoFilter Field:=1, Criteria1:="TRUE"
.EntireRow.Delete
On Error Resume Next
.EntireColumn.Delete
On Error GoTo 0
End With
Next
Application.ScreenUpdating = True
End Sub
sub delete_err_rows()
Dim Wbk as Excel.workbook 'create excel workbook object
Dim Wsh as worksheet ' create excel worksheet object
Dim Last_row as long
Dim i as long
Set Wbk = Thisworkbook ' im using thisworkbook, assuming current workbook
' if you want any other workbook just give the name
' in invited comma as "workbook_name"
Set Wsh ="sheetname" ' give the sheet name here
Wbk.Wsh.activate
' it means Thisworkbook.sheets("sheetname").activate
' here the sheetname of thisworkbook is activated
' or if you want looping between sheets use thisworkbook.sheets(i).activate
' put it in loop , to loop through the worksheets
' use thisworkbook.worksheets.count to find number of sheets in workbook
Last_row = ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row 'to find the lastrow of the activated sheet
For i = lastrow To 1 step -1
if activesheet.cells(i,"A").value = "yourDesiredvalue"
activesheet.cells(i,"A").select ' select the row
selection.entirerow.delete ' now delete the entire row
end if
Next i
end sub
Note any operations that you do using activesheet , will be affected on the currently activated sheet
As your saying your a begginner, why dont you record a macro and check out, Thats the greatest way to automate your process by seeing the background code
Just find the macros tab on the sheet and click record new macro , then select any one of the row and do what you wanted to do , say deleting the entire row, just delete the entire row and now go back to macros tab and click stop recording .
Now click alt+F11 , this would take you to the VBA editor there you find some worksheets and modules in the vba project explorer field , if you dont find it search it using the view tab of the VBA editor, Now click on module1 and see the recorded macro , you will find something like these
selection.entirerow.delete
I hope i helped you a bit , and if you need any more help please let me know, Thanks
Fastest method:
Sub DeleteUsingAutoFilter()
Application.ScreenUpdating = False
With ActiveSheet
.AutoFilterMode = False
.Columns("A").AutoFilter Field:=1, Criteria1:="ERR"
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
End Sub
Second fastest method (lots of variations to this one too):
Sub DeleteWithFind()
Dim rFound As Range, rDelete As Range
Dim sAddress As String
Application.ScreenUpdating = False
With Columns("A")
Set rFound = .Find(What:="ERR", After:=.Resize(1, 1), SearchOrder:=xlByRows)
If Not rFound Is Nothing Then
Set rDelete = rFound
Do
Set rDelete = Union(rDelete, rFound)
Set rFound = .FindNext(rFound)
Loop While rFound.Row > rDelete.Row
End If
If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
End With
Application.ScreenUpdating = True
End Sub
Autofilter method for multiple sheets:
Sub DeleteUsingAutoFilter()
Dim vSheets As Variant
Dim wsLoop As Worksheet
Application.ScreenUpdating = False
'// Define worksheet names here
vSheets = Array("Sheet1", "Sheet2")
For Each wsLoop In Sheets(vSheets)
With wsLoop
.AutoFilterMode = False
.Columns("A").AutoFilter Field:=1, Criteria1:="ERR"
.AutoFilter.Range.Offset(1, 0).EntireRow.Delete
.AutoFilterMode = False
End With
Next wsLoop
Application.ScreenUpdating = True
End Sub
Assuming there are always values in the cells in column A and that the data is in the first sheet, then something like this should do what you want:
Sub deleteErrRows()
Dim rowIdx As Integer
rowIdx = 1
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
While ws.Cells(rowIdx, 1).Value <> ""
If ws.Cells(rowIdx, 1).Value = "ERR" Then
ws.Cells(rowIdx, 1).EntireRow.Delete
Else
rowIdx = rowIdx + 1
End If
Wend
End Sub

Resources