I'm creating a macro that is formatting a collection of files and a step in this process is to delete columns that aren't required, keeping a specific set of columns.
I know I can delete columns based on their location and I have this approach implemented already ie 1,3,7 etc or A, C, G etc. But I'm conscious that the report being used might change layout or add extra columns over time and I want to ensure the required columns are kept.
Ideally this code would cycle through each column header starting at A1 until the last column and delete an entire column if the header value isn't found in a list. This list will be an array captured from a range in one of the sheets in the workbook.
List = {Blue, Green, Orange}
Original Table
Blue
Red
Green
Orange
Black
row
row
row
row
row
Formatted Table
Blue
Green
Orange
row
row
row
Does anyone have any suggestions on the approach I could take to get this working or if it's even possible? Any help would be greatly appreciated
You might profit from the following approach by reordering a datafield array via Application.Index which allows even to move the existing columns to any new position.
Note: this flexible solution can be time consuming for greater data sets,
where I would prefer other ways you can find in a lot of answers at SO.
Sub ReorderColumns()
Const headerList As String = "Blue,green,Orange"
'a) define source range
Dim src As Range
Set src = Tabelle3.Range("A1:E100")
'b) define headers
Dim allHeaders: allHeaders = src.Resize(1).Value2
Dim newHeaders: newHeaders = Split(headerList, ",")
'c) get column positions in old headers
Dim cols
cols = getCols(newHeaders, allHeaders)
'd) define data
Dim data As Variant
data = src.Value2
'e) reorder data based on found column positions
data = Application.Index(data, Evaluate("row(1:" & UBound(data) & ")"), cols)
'f) overwrite source data
src = vbNullString ' clear
src.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help function getCols()
Function getCols(individualHeaders, allHeaders)
'Purp: get 1-based column numbers of found headers via Match
getCols = Application.Match(individualHeaders, allHeaders, 0) ' 1-based
End Function
Please, test the next code. It is compact and fast enough. It will build the columns to be deleted range using Application.Match for the two involved arrays (the existing headers one and the ones to be kept). This code assumes that the headers exist in the first row of the processed sheets, starting from A:A column (If starting from a different column, the code can be adapted:
Sub DeleteColunsNotInArrayDel()
Dim sh As Worksheet, arrStay, lastCol As Long, arrH, arrCols, rngDel As Range
Set sh = ActiveSheet 'use here the sheet you need to process
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column 'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
arrH = Application.Transpose(Application.Transpose(sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)).Value2)) 'existing headers array
arrCols = Application.IfError(Application.match(arrH, arrStay, 0), "xx") 'match the two arrays and place "xx" where no match has been found
makeColsRng(arrCols).Delete 'delete the columns range, at once
End Sub
Function makeColsRng(arr) As Range
Dim i As Long, colL As String, strAddr As String
For i = LBound(arr) To UBound(arr) 'iterate between the matched arrays array
If arr(i) = "xx" Then 'for the not matching case:
colL = Split(cells(1, i).Address, "$")(1) 'extract the letter of the respective column
strAddr = strAddr & colL & "1," 'build the string of the columns to be deleted range
End If
Next i
Set makeColsRng = Range(left(strAddr, Len(strAddr) - 1)).EntireColumn 'return the necessary range
End Function
In case of headers not starting from the first sheet column, the function can easily be adapted by adding a new parameter (the first column number) to be added when the range to be deleted is built.
The above suggested solution is a fancy one, just for the sake of showing the respective approach, which is not too often used. It may have a limitation of the range building, in case of a string bigger than 254 digits, No error handling for the case of everything matching (even, easy to be added). The next version is standard VBA, compact, more reliable, faster and easier to be understood:
Sub DeleteColunsRangeNotInArray()
Dim sh As Worksheet, arrStay, lastCol As Long, rngH As Range, rngDel As Range, i As Long
Set sh = ActiveSheet
lastCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column'last column on the first row
arrStay = Split("Blue,Green,Orange", ",") 'the headers to not be deleted array
Set rngH = sh.Range(sh.cells(1, 1), sh.cells(1, lastCol)) 'existing headers range
For i = 1 To rngH.Columns.count
If IsError(Application.match(rngH(i).Value, arrStay, 0)) Then 'if not a match in arrStay:
addToRange rngDel, rngH(i) 'build a Union range
End If
Next i
'delete the not necessary columns at once:
If Not rngDel Is Nothing Then rngDel.EntireColumn.Delete
End Sub
Private Sub addToRange(rngU As Range, rng As Range)
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End Sub
Dynamic Named Range
I think a dynamic named range is an excellent choice for storing and retrieving your required columns. Please see the link I provided from https://exceljet.net/ to setup your dynamic named range.
Generic formula =$A$2:INDEX($A:$A,COUNTA($A:$A))
Regular Expression Approach
After reading in your named range, one approach for testing your columns is using regular expressions. To use this you will need to set a library reference to Microsoft VBScript Regular Expressions 5.5. The pipe character | represents an or statement, so we can join our array using that delimiter.
Deleting Ranges in loops
When deleting columns or rows within a loop, the best approach I have found is to union the ranges together in a variable and execute the deletion in one go. This helps performance and it prevents errors from deleting ranges the loop is working on.
I do this so often that I created a custom function for this UnionRange
' Helper function that allows
' concatinating ranges together
Public Function UnionRange( _
ByRef accumulator As Range, _
ByRef nextRange As Range _
)
If accumulator Is Nothing Then
Set UnionRange = nextRange
Else
Set UnionRange = Union(accumulator, nextRange)
End If
End Function
Putting it all together
Below is my implementation of what your code could look like, just make sure to first:
Create a Dynamic Named Range and populate with your required headers
Add Microsoft VBScript Regular Expressions 5.5 reference
Update Sheet1 to whatever sheet your table exists (possibly change logic for finding header row based on your needs)
' Need Regular Expressions Referenced in order to work!
' #libraryReference {Microsoft VBScript Regular Expressions 5.5}
Public Sub DemoDeletingNonRequiredColumns()
' Make sure to create a named range
' otherwise this section will fail. In this
' example the named range is `RequiredColumns`
Dim requiredColumns() As Variant
requiredColumns = Application.WorksheetFunction.Transpose( _
Range("RequiredColumns").Value2 _
)
' To test if the column is in the required
' columns this method uses regular expressions.
With New RegExp
.IgnoreCase = True
' The pipe charactor is `or` in testing.
.Pattern = Join(requiredColumns, "|")
Dim headerRow As Range
' This example uses `Sheet1`, but update to
' the actual sheet you are using.
With Sheet1
Set headerRow = .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
End With
Dim column As Range
For Each column In headerRow
' If the column name doesn't match the
' pattern, then concatenate it to the
' toDelete range.
If Not .Test(column.Value2) Then
Dim toDelete As Range
Set toDelete = UnionRange(toDelete, column.EntireColumn)
End If
Next
End With
' toDelete is used as it provides better performance
' and it also prevents errors when deleting columns
' while looping.
If Not toDelete Is Nothing Then
toDelete.Delete
Set toDelete = Nothing
End If
End Sub
Delete Columns Not In a List
Option Explicit
Sub DeleteIrrelevantColumns()
' Source - the worksheet containing the list of headers.
Const sName As String = "Sheet2"
Const sFirstCellAddress As String = "A2"
' Destination - the worksheet to be processed.
Const dName As String = "Sheet1"
Const dFirstCellAddress As String = "A1"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sData() As Variant
With sfCell
Dim slCell As Range: Set slCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
sData = .Resize(slCell.Row - .Row + 1).Value
End With
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sValue As Variant
Dim sr As Long
For sr = 1 To UBound(sData)
sValue = sData(sr, 1)
If Not IsError(sValue) Then ' exclude error values
If Len(sValue) > 0 Then ' exclude blanks
sDict(sValue) = Empty ' write
End If
End If
Next sr
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range
With dfCell
Dim dlCell As Range: Set dlCell = _
.Resize(, dws.Columns.Count - .Column + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
Set drg = .Resize(, dlCell.Column - .Column + 1)
End With
Dim dData() As Variant: dData = drg.Value
Dim dCells As Range
Dim dValue As Variant
Dim dc As Long
For dc = 1 To UBound(dData, 2)
dValue = dData(1, dc)
If sDict.Exists(dValue) Then
' If duplicate columns, keep only the left-most.
sDict.Remove dValue
Else
' Combine the irrelevant header cells into a range.
If dCells Is Nothing Then
Set dCells = drg.Cells(dc)
Else
Set dCells = Union(dCells, drg.Cells(dc))
End If
End If
Next dc
' Delete columns in one go.
If Not dCells Is Nothing Then
dCells.EntireColumn.Delete
End If
' Inform.
If sDict.Count = 0 Then
MsgBox "Irrelevant columns deleted.", vbInformation
Else
MsgBox "Irrelevant columns deleted." & vbLf & vbLf _
& "Columns not found:" & vbLf _
& Join(sDict.Keys, vbLf), vbCritical
End If
End Sub
I am new to VBA macros. I am trying to create a macro that that finds column name "Load Type" applies filter on column value LCL and keep only data rows with LCL and removes rest all data rows.
Example Macro should work like
Search column named "Load Type"
Select/ Filter column Value with LCL
Remove all other data other than LCL
If column named "Load Type", value <> LCL then entire row delete.
I want the macro to keep only data with value LCL in column named Load Type and remove rest all data even if there is blank it should remove the entire row if load type is blank.
Column N heading is Load type has multiple values LCL, Blanks, BB. I want the macro to keep only data and corrospoding row with column "Load Type" value LCL and remove rest all data.
Desired output is in above image.
My coding image
I tried coading like this but its says variable not defined I am confused of do i fix this.
Sub SortLCL_Concat()
Dim wb As Workbook
Dim sRng As Range
Dim fRng As Range
Dim cel As Range
Dim tRow As Long
Dim fCol As Long
Set wb = ThisWorkbook
Set fRng = ActiveWorkbook.Worksheets("Main")
fCol = fRng.Column
tRow = ActiveWorkbook.Worksheets("Main").Cells(Rows.Count, 1).End(xlUp).Row
With ActiveWorkbook.Worksheets("Main")
For tRow = .Rows.Count To 2 Step -1
If .Cells(tRow, fCol).Value <> LCL Then .Rows(tRow).Delete
Next tRow
End With
End Sub
I want the macro to keep only data with value LCL in column named Load Type and remove rest all data even if there is blank it should remove the entire row if load type is blank.
Delete Data Rows Using AutoFilter
Option Explicit
Sub SortLCL_Concat()
Const wsName As String = "Main"
Const FilterColumnTitle As String = "Load Type"
Const FilterCriteria As String = "<>LCL"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
If ws.FilterMode Then ws.ShowAllData
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Dim fCol As Long: fCol = Application.Match(FilterColumnTitle, rg.Rows(1), 0)
Dim drg As Range: Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
rg.AutoFilter fCol, FilterCriteria
Dim vdrg As Range
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
ws.AutoFilterMode = False
If vdrg Is Nothing Then Exit Sub
vdrg.Delete xlShiftUp
End Sub
In the picture below, I'm trying to hide the rows that are empty in a certain cells (e.g. Row 39 to Row 48). Is is possible to do it in one click? I'm planning of doing it with VBA.
This is the formula that I'm currently using but the thing is the cells that I want to hide may not start at row 39 or ends at row 48, it depends on the data.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
'ws.Rows("39:48").Hidden = True
Next
End Sub
Hide 'Empty' Rows
This is a slightly different approach:
uses Option Explicit
uses constants and variables
uses For Each...Next loops for both, worksheets and cells
qualifies all objects (e.g. ws.Cells or rg.Cells, not just Cells)
combines empty cells into a range
unhides all rows in one go, then hides the 'empty' rows in another (go)
Option Explicit
Sub HideRows()
Const StartRow As Long = 9
Const EndRow As Long = 89
Const ColNum As Long = 3
Dim WorksheetNames As Variant
WorksheetNames = Array("NAMES", "AUGUST") ' add more
Dim ws As Worksheet ' Current Worksheet
Dim rg As Range ' Current Range
Dim hrg As Range ' Current Hide Range
Dim cCell As Range ' Current Cell in Range
' Loop through the worksheets in the workbook containing this code.
For Each ws In ThisWorkbook.Worksheets(WorksheetNames)
' Create a reference to the range of the current worksheet.
Set rg = ws.Range(ws.Cells(StartRow, ColNum), ws.Cells(EndRow, ColNum))
' or using resize:
'Set rg = ws.Cells(StartRow, ColNum).Resize(EndRow - StartRow + 1)
' Loop through the cells of the current range.
For Each cCell In rg.Cells
If IsEmpty(cCell) Then ' cell is empty
' Combine ('add') the current cell into the hide range.
If Not hrg Is Nothing Then ' for all except the first
Set hrg = Union(hrg, cCell)
Else ' for the first
Set hrg = cCell
End If
'Else ' cell is not empty - do nothing
End If
Next cCell
' Unhide all rows of the current range of the current worksheet.
rg.EntireRow.Hidden = False
If Not hrg Is Nothing Then ' there are combined cells
' Hide the rows of the hide range.
hrg.EntireRow.Hidden = True
' Reset the hide range variable for the next worksheet.
' Also, note that 'Union' works only with ranges from one worksheet.
Set hrg = Nothing
'Else ' there are no combined cells - do nothing
End If
Next ws
End Sub
I already made it. Below is the script that I used.
Sub HideRows()
Dim ws As Worksheet
For Each ws In Worksheets(Array("NAMES", "AUGUST"))
StartRow = 9
EndRow = 89
ColNum = 3
For i = StartRow To EndRow
If Not IsEmpty(Cells(i, ColNum).Value) Then
ws.Cells(i, ColNum).EntireRow.Hidden = False
Else
ws.Cells(i, ColNum).EntireRow.Hidden = True
End If
Next i
Next
End Sub
See below an image of my Excel Spreadsheet.
What I am trying to accomplish is add 3 blank rows atop of only the first instance each sequential month. So if a new month begins in February (or "2" basically), then 3 blank rows will be automatically added atop of it. I am trying to do this using VBA code. However, my problem runs into how certain functions treat numbers and dates(especially) different from text/strings.
My current VBA code Sub insert() (shown under my image file) uses the LEFT() function on cell A2, but it does not return the value I want, which is "1" or "01" (representing the numerical value of its month). Instead it returns its actual value "44200" etc. - not what I want. I need to find a way to have my VBA code do its job by inserting 3 blank rows atop of each new month. But it can't do that with the LEFT() function. And the MONTH() function won't work in that code either. How do I go about this and alter this code to make it work? Thank you for your help.
Sub insert()
Dim lastRow As Long
Dim done As Boolean
'change A to the longest column (most rows)
lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastRow
'change the 1 below to the necessary column (ie, use 4 for column D)
If Left(Cells(i, 1), 2) = "01" Then
Rows(i).insert
done = True
i = i + 1
End If
If done = True Then Exit For
Next
End Sub
Insert Rows on Month Change
On each change of month in cells of column A, it will insert 3 rows above the cell.
It loops from top to bottom and combines the critical cells (or the cells next to them) into a range: first the current cell then the previously combined cells. It alternates between the cells and the cells next to them to not get ranges of multiple cells (Application.Union in GetCombinedRangeReverse: Union([A1], [A2]) = [A1:A2], while Union ([A1], [B2]) = [A1,B2]).
In the end, it loops through the cells of the range to insert rows from bottom to top.
Option Explicit
Sub InsertRows()
Const fRow As Long = 2 ' First Row
Const dtCol As String = "A" ' Date Column
Const RowsToInsert As Long = 3
' Pick one:
' 1. Either (bad, but sometimes necessary)...
'Dim ws As Worksheet: Set ws = ActiveSheet ' could be the wrong one
' 2. ... or better...
'Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
'Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' name
' 3. ... or best:
Dim ws As Worksheet: Set ws = Sheet1 ' code name (not in parentheses)
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, dtCol).End(xlUp).Row
Dim irg As Range ' Insert Range
Dim pMonth As Long ' Previous Month
Dim cMonth As Long ' Current Month
Dim cValue As Variant ' Current Cell Value
Dim cOffset As Long ' Column Offset for GetCombinedRangeReverse
Dim r As Long
For r = fRow To lRow
cValue = ws.Cells(r, dtCol).Value
If IsDate(cValue) Then ' a date
cMonth = Month(cValue)
If cMonth <> pMonth Then ' a different month
pMonth = cMonth
' Changing the column to cover consecutive different months.
cOffset = IIf(cOffset = 0, 1, 0)
Set irg = GetCombinedRangeReverse(irg, _
ws.Cells(r, dtCol).Offset(, cOffset))
Else ' the same month
End If
Else ' not a date
End If
Next r
If irg Is Nothing Then Exit Sub
' This loop is running from bottom to top due to 'GetCombinedRangeReverse'.
Dim iCell As Range
For Each iCell In irg.Cells
iCell.Resize(RowsToInsert).EntireRow.insert
Next iCell
MsgBox "Rows inserted.", vbInformation, "Insert Rows"
End Sub
Function GetCombinedRangeReverse( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set GetCombinedRangeReverse = AddRange
Else
Set GetCombinedRangeReverse = Union(AddRange, CombinedRange)
End If
End Function
The code below will create a new sheet for each cell in column A. The second module will copy all rows that have a specific value in column A to a specific destination.
I created this so each work order number gets its own sheet and all rows with that work order number is copied over to the sheet named that work order number.
The issue is there are 604 unique work order numbers and I have to edit the second module for each work order in order for it to work.
Is there some way I could have it loop through all the values in column A and maybe compare it to a set variable and then copy the rows to the sheet that has that work order number? I don't know how to make the destination sheet be whatever new value is found in column A.
I'm new to VBA, so this question probably doesn't make much sense. And yes I have seen code for creating and naming a sheet based on each new work order in one module but it generally won't compile so I split the process out to 2 modules.
Anyway, to better understand what I mean: say column A has 4 rows for work order number 1234. I'd need the macro to copy all 4 rows for 1234 into the sheet that is named 1234. Then move on to the next work order number.
The range it is checking for work orders in is A2:A39986, but the full range is A2:F39986.
Thank you for your time.
Option Explicit
Sub parse_data()
Dim xRCount As Long
Dim xSht As Worksheet
Dim xNSht As Worksheet
Dim I As Long
Dim xTRow As Integer
Dim xCol As New Collection
Dim xTitle As String
Dim xSUpdate As Boolean
Set xSht = ActiveSheet
On Error Resume Next
xRCount = xSht.Cells(xSht.Rows.Count, 1).End(xlUp).Row
xTitle = "A60:A604"
xTRow = xSht.Range(xTitle).Cells(1).Row
For I = 2 To xRCount
Call xCol.Add(xSht.Cells(I, 1).Text, xSht.Cells(I, 1).Text)
Next
xSUpdate = Application.ScreenUpdating
Application.ScreenUpdating = False
For I = 1 To xCol.Count
Call xSht.Range(xTitle).AutoFilter(1, CStr(xCol.Item(I)))
Set xNSht = Nothing
Set xNSht = Worksheets(CStr(xCol.Item(I)))
If xNSht Is Nothing Then
Set xNSht = Worksheets.Add(, Sheets(Sheets.Count))
xNSht.Name = CStr(xCol.Item(I))
Else
xNSht.Move , Sheets(Sheets.Count)
End If
xSht.Range("A" & xTRow & xRCount).EntireRow.Copy xNSht.Range("A60")
xNSht.Columns.AutoFit
Next
xSht.AutoFilterMode = False
xSht.Activate
Application.ScreenUpdating = xSUpdate
End Sub
and the module that copies data to a specific destination:
Sub CopyColumnOver()
Dim wsSource As Worksheet
Dim wsDestin As Worksheet
Dim lngDestinRow As Long
Dim rngSource As Range
Dim rngCel As Range
Set wsSource = Sheets("Sheet1") 'Edit "Sheet1" to your source sheet name
Set wsDestin = Sheets("11556")
With wsSource
'Following line assumes column headers in Source worksheet so starts at row2
Set rngSource = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
For Each rngCel In rngSource
If rngCel.Value = "11556" Then
With wsDestin
'Following line assumes column headers in Destination worksheet
lngDestinRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
rngCel.EntireRow.Copy Destination:=wsDestin.Cells(lngDestinRow, "A")
End With
End If
Next rngCel
End Sub