Find column by column name and keep specific value of that column and remove all other data including blanks - excel

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

Related

copying a defined named range with merged cells from one worksheet to a new worksheet at a selected cell

Inspection templates
Depending on which inspection is going to be undertaken I load the inspection sheet (a name defined selection) from Inspection template and add it to a worksheet that contains all the tag information for a selected tag to be inspected
Sub copycells()
' copycells Macro
'
'
Application.Goto Reference:="Ex_d_Visual"
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("A9").Select
ActiveSheet.Paste
End Sub
the problem is that the merged cells height does not copy across to the new worksheet.
"EX_d_Visual" = A1:K41
I have tried many different copy paste options and paste special options but can't seem to get it to work, I think that I may need to use a "for cell next" loop and get each original cell height then set the new sheet equivalent cell to the same height. getting the cell height from the original is doable using the range "Ex_d_Visual" but just not sure how to set the new sheet as I only know the single cell that I have copied into.
Adjust Row Height in a Copied Range
Sub CopyCells()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim srg As Range: Set srg = wb.Names("Ex_d_Visual").RefersToRange
Dim dws As Worksheet: Set dws = wb.Sheets("Sheet1")
Dim dCell As Range: Set dCell = dws.Range("A9")
srg.Copy dCell
Dim sCell As Range
For Each sCell In srg.Cells
dCell.RowHeight = sCell.RowHeight
Set dCell = dCell.Offset(1)
Next sCell
End Sub
In your case, since you know that the destination merged range will have the same number of rows in it, you can define it using .Resize to be identical in size to the source range.
Then looping over the rows to apply the original row height could look like this:
Const RangeName = "Ex_d_Visual"
Const SheetName = "Sheet1"
Const RangeAddress = "A9"
Dim SourceRange As Range
Set SourceRange = ThisWorkbook.Names(RangeName).RefersToRange
Dim DestinationRange As Range
Set DestinationRange = ThisWorkbook.Sheets(SheetName).Range(RangeAddress).Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)
Dim Row As Range, Offset As Long
For Each Row In SourceRange.Rows
DestinationRange.Rows(1 + Offset).RowHeight = Row.Height
Offset = Offset + 1
Next Row

Select first 800 visible cells only form a column, even if there are more then 800 visible filtered cells

I need a VBA code, that will allow me to select and copy custom number of visible rows only.
For example: I filtered a column data, and the count of all the visible cells is 1000. However, I want to copy only the first 800 visible cells only out of the 1000 visible cells.
One idea is to get all visible cells using SpecialCells(xlCellTypeVisible) and then loop through and collect them one by one using Application.Union to limit them to your desired amount.
Option Explicit
Public Sub Example()
Dim Top800Cells As Range
Set Top800Cells = GetTopVisibleRows(OfRange:=Range("A:A"), TopAmount:=800)
Top800Cells.Select
End Sub
Public Function GetTopVisibleRows(ByVal OfRange As Range, ByVal TopAmount As Long) As Range
Dim VisibleCells As Range
Set VisibleCells = OfRange.SpecialCells(xlCellTypeVisible)
If VisibleCells Is Nothing Then
Exit Function
End If
Dim TopCells As Range
Dim Count As Long
Dim Row As Range
For Each Row In VisibleCells.Rows
If TopCells Is Nothing Then
Set TopCells = Row
Else
Set TopCells = Application.Union(TopCells, Row)
End If
Count = Count + 1
If Count = TopAmount Then Exit For
Next Row
Set GetTopVisibleRows = TopCells
End Function
If you want to use it as a UDF (user defined function) in a formula SpecialCells(xlCellTypeVisible) is known to fail there (see SpecialCells(xlCellTypeVisible) not working in UDF). And you need to check visibility yourselft:
Public Function GetTopVisibleRows(ByVal OfRange As Range, ByVal TopAmount As Long) As Range
Dim TopCells As Range
Dim Count As Long
Dim Row As Range
For Each Row In OfRange.Rows
If Not Row.EntireRow.Hidden Then
If TopCells Is Nothing Then
Set TopCells = Row
Else
Set TopCells = Application.Union(TopCells, Row)
End If
Count = Count + 1
If Count = TopAmount Then Exit For
End If
Next Row
Set GetTopVisibleRows = TopCells
End Function
Copy First n Rows of SpecialCells(xlCellTypeVisible)
This is usually done to more columns as illustrated in the code.
To apply it just to column A, replace Set rg = ws.Range("A1").CurrentRegion with
Set rg = ws.Range("A1").CurrentRegion.Columns(1)
assuming that the header is in the first worksheet row.
In a nutshell, it loops through the rows (rrg) of each area (arg) of the range (MultiRange, dvrg) counting each row (r) and when it hits the 'mark' (DataRowsCount), it uses this row (Set SetMultiRangeRow = rrg, lrrg) and the first row (frrg) as arguments in the range property to set the required range and reapply the same type of SpecialCells to finally reference the required amount of rows.
Sub ReferenceFirstMultiRangeRows()
' Define constants
Const CriteriaColumn As Long = 1
Const CriteriaString As String = "Yes"
Const DataRowsCount As Long = 800
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the ranges.
Dim rg As Range ' the range (has headers)
Set rg = ws.Range("A1").CurrentRegion ' you may need to use another way!
Dim drg As Range ' the data range (no headers)
Set drg = rg.Resize(rg.Rows.Count - 1).Offset(1)
' Apply the auto filter to the range.
rg.AutoFilter CriteriaColumn, CriteriaString
' Attempt to reference the visible data range ('vdrg').
Dim vdrg As Range
On Error Resume Next
Set vdrg = drg.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' Reference the required amount of visible rows ('vdrg').
' Reference the partial range ('vdrg') from the first row
' to the DataRowsCount-th row of the visible range
' and reapply special cells to this range.
If Not vdrg Is Nothing Then ' filtered rows found
Dim lrrg As Range: Set lrrg = SetMultiRangeRow(vdrg, DataRowsCount)
If Not lrrg Is Nothing Then ' there are more rows than 'DataRowsCount'
Dim frrg As Range: Set frrg = vdrg.Rows(1)
Set vdrg = ws.Range(frrg, lrrg).SpecialCells(xlCellTypeVisible)
'Else ' the visible data range is already set; do nothing
End If
'Else ' no filtered rows found; do nothing
End If
ws.AutoFilterMode = False ' remove the auto filter
If vdrg Is Nothing Then
MsgBox "No filtered rows.", vbExclamation
Exit Sub
End If
' Continue using vdrg e.g.:
Debug.Print vdrg.Address ' only the first <=257 characters of the address
'vdrg.Select
'vdrg.Copy Sheet2.Range("A2")
End Sub
Function SetMultiRangeRow( _
ByVal MultiRange As Range, _
ByVal MaxRowNumber As Long) _
As Range
Dim rCount As Long
rCount = MultiRange.Cells.CountLarge / MultiRange.Columns.Count
If rCount < MaxRowNumber Then Exit Function
Dim arg As Range
Dim rrg As Range
Dim r As Long
Dim lrrg As Range
For Each arg In MultiRange.Areas
For Each rrg In arg.Rows
r = r + 1
If r = MaxRowNumber Then
Set SetMultiRangeRow = rrg
Exit For
End If
Next rrg
Next arg
End Function

VBA cannot AutoFilter a Range for a certain criteria

I am trying to make a Range object of all entrys and than apply a filter, which searches for a number in there.
I want the Range to hold only the matching entrys afterwards, but I always get the error 1004...
Here the code:
Dim rSearch As Range
Dim rResult As Range
Set rSearch = wbMe.Sheets(iCurSheet).Range("F2:F1000")
rSearch.AutoFilter Field:=iColKey, Criteria1:="=" & wbMe.Sheets(iCurSheet).Cells(iLine, iColKey).Value
The last line throws the exception. I found out that the AutoFilter has to be applied to the first line, so .Range("A1:K1"), but I still don't get why I am not able to Filter on a Range, maybe i get the Object wrong?
Thanks in advance!
Edit:
So I tried some stuff:
Set rSearch = wbMe.Sheets(iCurSheet).Range("A2:K1000")
rSearch.AutoFilter Field:=11, Criteria1:="=" & wbMe.Sheets(iCurSheet).Cells(iLine, iColKey).Value
MsgBox "Count Rows rSearch:" & rSearch.Rows.Count
I expected the MsgBox to say smth less, but I get 999, so it hasn't filtered anything.
My guess that I was filtering the wrong column, but I wanna filter on Col K (I need Col F afterwards to search once more, sry for mixing stuff up).
Now I don't get the AutoFilter exception anymore. But for some reason my rSearch range does not shrink.
How do I shrink my Range?
Count Visible Data Cells (Criteria Cells)
A quick fix could be something like
MsgBox "Count Rows rSearch:" & rSearch.Columns(11).SpecialCells(xlCellTypeVisible).Cells.Count - 1
Note that the headers need to be included in the range for AutoFilter to work correctly.
Using SpecialCells
Sub CountVisibleDataCells()
' Define constants.
Const CriteriaIndex As Long = 11
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("A1:K21")
' Store the criteria value from the cell, converted to a string ('CStr'),
' in a string variable ('Criteria'). AutoFilter 'prefers' this.
Dim Criteria As String: Criteria = CStr(ws.Range("M1").Value)
' Filter the range.
rg.AutoFilter Field:=CriteriaIndex, Criteria1:=Criteria
' Reference the visible cells in the criteria column ('vrg').
Dim vrg As Range
Set vrg = rg.Columns(CriteriaIndex).SpecialCells(xlCellTypeVisible)
' Turn off the worksheet auto filter.
ws.AutoFilterMode = False
' Store the number of visible cells of the criteria column
' in a long variable (subtract 1 to not count the header).
Dim CriteriaCount As Long: CriteriaCount = vrg.Cells.Count - 1
' Inform.
MsgBox "Count of '" & Criteria & "': " & CriteriaCount
End Sub
Using Application Count
Sub CountCriteriaCells()
' Define constants.
Const CriteriaIndex As Long = 11
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
' Turn off AutoFilter.
If ws.AutoFilterMode Then ws.AutoFilterMode = False
' Reference the range ('rg').
Dim rg As Range: Set rg = ws.Range("A1:K21")
' Store the criteria value from the cell, converted to a string ('CStr'),
' in a string variable ('Criteria').
Dim Criteria As String: Criteria = CStr(ws.Range("M1").Value)
' You may need to modify this because 'CountIf' works differently.
' Reference the criteria data range ('cdrg') (no headers).
Dim cdrg As Range
With rg.Columns(CriteriaIndex)
Set cdrg = .Resize(.Rows.Count - 1).Offset(1)
End With
' Store the number of cells containing the criteria ('CriteriaCount')
' in a long variable.
Dim CriteriaCount As Long
CriteriaCount = Application.CountIf(cdrg, Criteria)
' Inform.
MsgBox "Count of '" & Criteria & "': " & CriteriaCount
End Sub

Trouble copying duplicated values to a new sheet

I've been tooling with this code originally provided by #Tim Williams.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Variant, cDest As Range, c As Range
Set wb = Workbooks("1")
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).row).Cells
m = Application.Match(c.Value, wsB.Columns("D"), 0) 'Match is faster than Find
If Not IsError(m) Then 'got a match?
wsB.Rows(m).Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
End If
Next c
End Sub
It searches through all the values in a column in Sheet A, finds those matching cells in a column of Sheet B, and finally copies that entire row to Sheet C.
It's working great, but I cant crack how to handle certain cases of duplicates.
If Sheet A has duplicates (ie. one cell contains "test" and the following cell contains "test"). It works great if Sheet B only has one cell that contains "test", as it copies this value over the the new sheet twice.
However, In Sheet B, if the cell containing 'test' is followed by another cell containing 'test', it only copies over the first one, not the one below it as well.
I'm having a hard enough time wrapping my head around even the logic of this, thanks for any input.
You would want to put a second loop inside the first loop, and create something with the logic "For Each Match that I find for this c.Value in Sheet B Column D... Do that copy paste code block"
To find multiple matches of the same value, you can use a FindNext loop. I am not familiar with the Match function and I don't know if its loopable.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Range, cDest As Range, c As Range, firstAddress As String
Set wb = Workbooks(1)
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).Row).Cells
Set m = wsB.Columns("D").Find(c.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True) ' attempt a match
If Not m Is Nothing Then 'got a match?
firstAddress = m.Address 'save the first match
Do 'loop for every match
m.EntireRow.Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
Set m = wsB.Columns("D").FindNext(after:=m) 'move to the next match
Loop While m.Address <> firstAddress 'check that the next match isnt the same as the first
End If
Next c
End Sub
So that above code will handle duplicates on Sheet B, but what to do if there are duplicates on sheet A? I suggest using a dictionary to keep track of c.Value and if it detects a duplicate, skips it.
Sub matchData()
Dim wb As Workbook, wsA As Worksheet, wsB As Worksheet, wsC As Worksheet
Dim m As Range, cDest As Range, c As Range, firstAddress As String
Dim cVals As Object
Set wb = Workbooks(1)
Set wsA = wb.Sheets("A")
Set wsB = wb.Sheets("B")
Set wsC = wb.Sheets("C")
Set cVals = CreateObject("Scripting.Dictionary")
Set cDest = wsC.Range("A2") 'start pasting here
For Each c In wsA.Range("A1:A" & wsA.Cells(Rows.Count, "A").End(xlUp).Row).Cells
If Not cVals.exists(c.Value) Then
cVals.Add c.Value, 0
Set m = wsB.Columns("D").Find(c.Value, LookIn:=xlValues, Lookat:=xlWhole, MatchCase:=True) ' attempt a match
If Not m Is Nothing Then 'got a match?
firstAddress = m.Address 'save the first match
Do 'loop for every match
m.EntireRow.Copy cDest 'copy matched row
Set cDest = cDest.Offset(1, 0) 'next paste row
Set m = wsB.Columns("D").FindNext(after:=m) 'move to the next match
Loop While m.Address <> firstAddress 'check that the next match isnt the same as the first
End If
End If
Next c
End Sub
You can see above, each loop checks to see if dictionary cVals already has the current value in the dictionary, and only continues with the code if it doesn't, otherwise moving to the next loop iteration.
A VBA Lookup: Lookup Direction
A Rule of Thumb
When there are two columns, you can lookup in two directions.
If you will be copying all the matches in column B, you should loop through the cells in column B and find matches in column A (see A Quick Fix).
Note that you could write all the unique values from column A to an array of strings and use it as the parameter of the Criteria1 argument of the AutoFilter method to filter the data in column B and copy it in one go. But we're playing around here, aren't we?
If the order of the values in column A matters, and there are duplicates in column B then you cannot easily use Application.Match but you could use a combination of the Find and FindNext methods.
I Wonder...
Why should it copy a found row twice ("It works great..., as it copies this value over to the new sheet twice")?
A Quick Fix
Option Explicit
Sub CopyMatches()
Dim wb As Workbook: Set wb = Workbooks("1")
Dim lws As Worksheet: Set lws = wb.Worksheets("A")
Dim sws As Worksheet: Set sws = wb.Worksheets("B")
Dim dws As Worksheet: Set dws = wb.Worksheets("C")
Dim lrg As Range ' Lookup
Set lrg = lws.Range("A2:A" & lws.Cells(lws.Rows.Count, "A").End(xlUp).Row)
Dim srg As Range ' Source
Set srg = sws.Range("D2:D" & sws.Cells(sws.Rows.Count, "D").End(xlUp).Row)
Dim dCell As Range ' Destination
Set dCell = dws.Range("A2") ' needs to be column 'A' because 'EntireRow'
'dCell.EntireRow.Offset(dws.Rows.Count - dCell.Row + 1).Clear
Dim sCell As Range
For Each sCell In srg.Cells
If IsNumeric(Application.Match(sCell, lrg, 0)) Then
sCell.EntireRow.Copy dCell
Set dCell = dCell.Offset(1)
End If
Next sCell
MsgBox "Data copied.", vbInformation
End Sub

Excel VBA delete row if cell contains string [duplicate]

This question already has answers here:
VBA: Searching substring and deleting entire row
(2 answers)
Delete entire row if cell contains the string X
(7 answers)
Closed 1 year ago.
I have data sheets that vary in size week to week. I want to delete rows which contain the string "CHF" which is in column D, but again, column D changes in size each week. I don't even know where to start with this. I've looked at the similar questions recommended when writing this question but still have not figured it out. Any solutions?
Delete Rows (For...Next Loop feat. Union)
Adjust the values in the constants section.
Option Explicit
Sub deleteRows()
' Define constants.
Const wsName As String = "Sheet1"
Const cFirst As Long = 2
Const cCol As String = "D"
Const Crit As String = "CHF"
' Define workbook, worksheet, and last row.
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
Dim cLast As Long: cLast = ws.Cells(ws.Rows.Count, cCol).End(xlUp).Row
' Combine cells ('cCell') containing Criteria into Delete Range ('drg').
Dim drg As Range
Dim cCell As Range
Dim i As Long
For i = cFirst To cLast
Set cCell = ws.Cells(i, cCol)
If cCell.Value = Crit Then
If drg Is Nothing Then
Set drg = cCell
Else
Set drg = Union(drg, cCell)
End If
End If
Next i
' Delete entire rows of Delete Range in one go.
If Not drg Is Nothing Then
drg.EntireRow.Delete
End If
End Sub
This is the basic premise of Filter and Delete mentioned earlier by #BigBen
Sub FilterDelete()
Application.DisplayAlerts = False
Dim rng As Range
Dim LR as Long
LR=Worksheets("Sheet1").Cells(Rows.Count,1).End(xlUp).Row
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:H"&LR)
rng.AutoFilter Field:=4, Criteria1:="CHF"
rng.Offset(1,0).SpecialCells(xlCellTypeVisible).Delete
AutoFilterMode = False
Application.DisplayAlerts = True
End Sub
You may have more or less columns. You can use a similar method to find the last column. Not seeing your data, I am giving an example.

Resources