everyone. I am new in VBA language. From my situation,
1) I would like to filter "unfulfilled" from column H and delete it
2) I would like to filter "Y" from column Q and delete it
I have write some code to run it. When I press run at the 1st time I am able to filter and delete 1st requirement, but if I want to filter and delete 2nd requirement I need to press Run again. May I know how to run those requirement once. Attachment below are my code
Sub try2()
Dim Filterrng1 As Range, Filterrng2 As Range
Dim Delrng1 As Range, Delrng2 As Range
Dim FilterArr1
Dim FilterArr2
Application.ScreenUpdating = False
FilterArr1 = Array("Unfulfilled")
FilterArr2 = Array("Y")
Set Filterrng1 = Range("H1", Range("H" & Rows.Count).End(xlUp))
Set Filterrng2 = Range("Q1", Range("Q" & Rows.Count).End(xlUp))
Set Delrng1 = Filterrng1.Offset(1, 0)
Set Delrng2 = Filterrng2.Offset(1, 0)
Debug.Print LBound(FilterArr1)
Debug.Print LBound(FilterArr2)
For f = LBound(FilterArr1) To UBound(FilterArr1)
Filterrng1.AutoFilter Field:=1, Criteria1:="=" & FilterArr1(f)
If Filterrng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
Delrng1.EntireRow.Delete
End If
For a = LBound(FilterArr2) To UBound(FilterArr2)
Filterrng2.AutoFilter Field:=1, Criteria1:="=" & FilterArr2(a)
If Filterrng2.SpecialCells(xlCellTypeVisible).Count > 1 Then
Delrng2.EntireRow.Delete
End If
Next
Next
Filterrng1.AutoFilter 'Remove Autofilter from range
Filterrng2.AutoFilter 'Remove Autofilter from range
End Sub
sub try3()
Dim rg As Range
Set rg = ActiveSheet.Range("H1").CurrentRegion 'Edit to your range
Dim Filterrng1 As Range, Filterrng2 As Range
Dim Delrng1 As Range, Delrng2 As Range
Dim FilterArr1
Dim FilterArr2
Set Filterrng1 = Range("H1", Range("H" & Rows.Count).End(xlUp))
Set Filterrng2 = Range("Q1", Range("Q" & Rows.Count).End(xlUp))
Set Delrng1 = Filterrng1.Offset(1, 0)
Set Delrng2 = Filterrng2.Offset(1, 0)
rg.AutoFilter Field:=1, Criteria1:="Unfulfilled"
If Filterrng1.SpecialCells(xlCellTypeVisible).Count > 1 Then
Delrng1.EntireRow.Delete
End If
rg.AutoFilter
rg.AutoFilter Field:=10, Criteria1:="Y"
If Filterrng2.SpecialCells(xlCellTypeVisible).Count > 1 Then
Delrng2.EntireRow.Delete
End If
end sub
Add other things like screenupdating, etc.
Related
I would like to change the color of certain text in the cells based on the values in another cells. I have tried using conditional formatting but it does not work since I only wanted to change the color of particular words in the cells. I have googled a few VBA codes as well but still could not find the right one. Is there any VBA Code to enable this?
As shown in the example below (see image), I want to highlight ONLY the dates in Column B and C that match the dates in Column G. The day should remain the same.
For information, the values in Column B and C are formatted as text and the values in G are formatted as date.
Before
and this is basically what I wish for.
After
I have modified code appropriately as per your requirement in the comment.
Sub Change_Text_Color()
Dim Find_Text, Cell, Cell_in_Col_G, LastCell_inColG As Range
Dim StartChar, CharLen, LastUsedRow_inRange, LastUsedRow_inColB, _
LastUsedRow_inColC As Integer
LastUsedRow_inColB = Sheet1.Cells(Rows.count, "B").End(xlUp).Row
LastUsedRow_inColC = Sheet1.Cells(Rows.count, "C").End(xlUp).Row
LastUsedRow_inRange = Application.WorksheetFunction. _
Max(LastUsedRow_inColB, LastUsedRow_inColC)
Set LastCell_inColG = Sheet1.Cells(Rows.count, "G").End(xlUp)
For Each Cell In Range(Sheet1.Cells(2, 2), Cells(LastUsedRow_inRange, 3))
For Each Cell_in_Col_G In Range(Sheet1.Cells(2, 7), LastCell_inColG)
CharLen = Len(Cell_in_Col_G.Text)
Set Find_Text = Cell.Find(what:=Cell_in_Col_G.Text)
If Not Find_Text Is Nothing Then
StartChar = InStr(Cell.Value, Cell_in_Col_G.Text)
With Cell.Characters(StartChar, CharLen)
.Font.Color = RGB(0, 255, 0)
End With
End If
Next
Next
End Sub
Please let me know your feedback on it.
Use Characters:
With Range("a1")
.Characters(Start:=1, Length:=4).Font.Color=0
.Characters(Start:=5, Length:=10.Font.Color=255
End With
colours the first four letters black and the next ten in red.
Ref:
https://learn.microsoft.com/en-us/office/vba/api/excel.characters
I find filtering works well in these scenarios. Assuming that the format of your sheet is as it is in your sample sheets, try the code below:
Sub MarkDatesInCells()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet3") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
' Turn off updating
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Clear autofilter if exists
If .AutoFilterMode Then .AutoFilterMode = False
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
.UsedRange.AutoFilter iC, "=*" & oHighlightRng.Value
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
.AutoFilterMode = False
Next
Next
End With
' Turn on updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
EDIT
Based on your requirement to have this solution for a sheet with a table connected to a database, try the below code. I don't have a database that I can test the below code on so you might have to tinker with it a bit to get it right (i.e. the text that is highlight)
Sub MarkDatesInCellsInATable()
Dim oWS As Worksheet: Set oWS = ThisWorkbook.Worksheets("Sheet4") '<- Change to the sheet name
Dim iLRToHighlight As Long, iStartChar As Long, iC As Long, iLR As Long
Dim oHighlightRng As Range, oUpdateRng As Range, oRng As Range
Dim sColName As String
Dim oTable As ListObject: Set oTable = oWS.ListObjects("Table_ExceptionDetails.accdb") '<- Change to the table name
Application.ScreenUpdating = False
Application.EnableEvents = False
With oWS
' Reset autofilter
oTable.Range.AutoFilter
' Loop through all values specified in column G
iLRToHighlight = .Range("G" & .Rows.Count).End(xlUp).Row
For Each oHighlightRng In .Range("G2:G" & iLRToHighlight)
' Loop through column B and C
For iC = 2 To 3
' Set autofilter based on the value in column G
oTable.Range.AutoFilter iC, "=*" & oHighlightRng.Value & "*"
' Loop through all visible rows
iLR = .Cells(.Rows.Count, iC).End(xlUp).Row
If iLR > 1 Then
sColName = Left(Replace(.Cells(1, iC).Address, "$", ""), 1)
Set oUpdateRng = .Range(sColName & "2:" & sColName & iLR).SpecialCells(xlCellTypeVisible)
' Update each cell text
For Each oRng In oUpdateRng
iStartChar = InStr(1, oRng.Value, "- ", vbTextCompare) + 2
oRng.Characters(Start:=iStartChar, Length:=Len(oHighlightRng.Value)).Font.Color = 255
Next
End If
oTable.Range.AutoFilter
Next
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I'm beginner at Macros I need to do a copy of rows but I have to exclude some columns. EntireRow is working but I need to exclude the columns I,G,H
Sub Macro1()
Dim RngToChk as Range, RngToPaste as Range
Set RngToCheck=Application.InputBox(Prompt:="enter range", Type:=8)
Dim strtofind as String
Inttofind=InputBox("Give your Indicator")
Dim i as long
For i = RngToChk.Rows.Count To 1 Step -1
If RngToChk(i).value=strtofind Then
RngToCheck(i).Offset(1).EntireRow.Insert
Set RngToPaste=RngToChk(i).Offset(1)
RngToPaste.EntireRow.Value=RngToChk(i).EntireRow.Value
RngToPaste.EntireRow.Font.Color=RGB(255,0,0)
End If
Next i
End Sub
Add this function to your module:
Function AlmostEntireRow(StartingPoint As Range) As Range
Dim Row As Long
Dim TargetSheet As Worksheet
Row = StartingPoint.Row
Set TargetSheet = StartingPoint.Worksheet
Set AlmostEntireRow = Union(TargetSheet.Range("A" & Row & ":F" & Row), TargetSheet.Range("J" & Row & ":GR" & Row))
End Function
When you are using it, replace
RngToPaste.EntireRow.Font.Color=RGB(255,0,0)
with
AlmostEntireRow(RngToPaste).Font.Color = RGB(255, 0, 0)
and so on.
The function builds a range from the input range, consisting of columns A to F and J to GR. Adjust as needed.
Update
The suggested method does not work when copying rows. Here is a copy method as well.
Sub CopyAlmostEntireRow(FromRow As Range, ToRow As Range)
Dim FromRange As Range
Dim ToRange As Range
Set FromRange = FromRow.Worksheet.Range("A" & FromRow.Row & ":F" & FromRow.Row)
Set ToRange = ToRow.Worksheet.Range("A" & ToRow.Row & ":F" & ToRow.Row)
ToRange.Value = FromRange.Value
Set FromRange = FromRow.Worksheet.Range("J" & FromRow.Row & ":GR" & FromRow.Row)
Set ToRange = ToRow.Worksheet.Range("J" & ToRow.Row & ":GR" & ToRow.Row)
ToRange.Value = FromRange.Value
End Sub
' Call with something like this:
CopyAlmostEntireRow RngToChk(i), RngToPaste
I have one Excel sheet with 6000 rows. I need to delete entire rows if distinct values are less than, say, three in one particular column.
Per below example:
In column-A with the list of colours and in column-B with names.
If I filter any 'name in column-B and in column-A, if less than three distinct values = true then entire row should be deleted.
Rows with name- Chary should be deleted.
A B
Color Employee
Red Dev
blue Dev
blue Dev
Red Dev
black Dev
Red Dev
Red Chary
blue Chary
blue Chary
Red Chary
Red Chary
Red Chary
With my code:
First I filter name in column-B then paste the filtered data new workbook and there I will remove duplicates from column-A then will get the unique count.
If the unique count is less than 3 then activate the main sheet and will delete filtered rows and loop to next name.
Sub Del_lessthan_5folois()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
t = Now()
Set wb = ActiveWorkbook
Sheets("VALID ARNS").Activate
iCol = 2 '### criteria column
Set ws = Sheets("VALID ARNS")
Sheets("VALID ARNS").Activate
Set rnglast = Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious)
ws.Columns(iCol).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngUnique = Range(Cells(2, iCol), rnglast).SpecialCells(xlCellTypeVisible)
Workbooks.Add
Set newb = ActiveWorkbook
For Each strItem In rngUnique
If strItem <> "" Then
ws.UsedRange.AutoFilter Field:=iCol, Criteria1:=strItem.Value
newb.Activate
ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy Destination:=[A1]
Application.CutCopyMode = False
Cells.EntireColumn.AutoFit
Dim uniq As Range
Set uniq = Range("A1:S" & Range("A" & Rows.Count).End(xlUp).Row)
uniq.RemoveDuplicates Columns:=7, Header:=xlYes
LastRow = ActiveSheet.UsedRange.Rows.Count
Cells.Delete Shift:=xlUp
Range("A1").Select
wb.Activate
If LastRow < "3" Then
ActiveSheet.AutoFilter.Range.Offset(1,0).Rows.SpecialCells(xlCellTypeVisible).Delete (xlShiftUp)
End If
End If
Next
ws.ShowAllData
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
ActiveSheet.AutoFilterMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
My code works in step by step debug mode but when run it skips a lot of rows.
Can this be related to more than 6000 rows?
How do I get the count of distinct values in Column-A when filtered in Column-B?
It's not exactly the same code that you posted as I had some troubles with it, but here's an alternative solution. I simply copy the data into another sheet (please add sheet called "Results" before you run my code), add two more columns with formulas (these will check if a given "Employee" should be deleted), filter on "TRUE" and then delete relevant rows.
From what I tested such solution seems to be faster than applying Advanced Filters, checking for unique values and then looping through the whole dataset. I hope it will work fine for your setup.
Here's the code:
Sub DeleteRows()
Dim t As Variant
Dim iCol As Long, lngLastRow As Long
Dim wsOrig As Worksheet, wsNew As Worksheet
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
t = Now()
Set wsOrig = Sheets("VALID ARNS")
Set wsNew = Sheets("Results")
iCol = 2 '### criteria column
With wsOrig
lngLastRow = .Columns(iCol).Find("*", Cells(1, iCol), , , xlByColumns, xlPrevious).Row
'copy into Results sheet
.Range("A1:B" & lngLastRow).Copy wsNew.Range("A1")
With wsNew
'add formulas
.Range("C1:D1").Value = VBA.Array("Instance", "Delete?")
.Range("C2:C" & lngLastRow).Formula = "=COUNTIFS($A$2:A2,A2,$B$2:B2,B2)"
.Range("D2:D" & lngLastRow).Formula = "=SUMIFS($C$2:$C$" & lngLastRow & ",$B$2:$B$" & lngLastRow & ",B2,$C$2:$C$" & lngLastRow & ",1)<3"
'delete when column D = TRUE
.Range("A1:D" & lngLastRow).AutoFilter Field:=4, Criteria1:="TRUE"
.Range("D2:D" & lngLastRow).SpecialCells(xlCellTypeVisible).Rows.Delete
'clear
.Range("A1:B" & lngLastRow).AutoFilter
.Range("C:D").Clear
End With
End With
MsgBox "The entire process took! " & Format(Now() - t, "hh:mm:ss") & " Minutes"
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
"VALID ARNS" sheet:
"Results" sheet (after running the code):
Edit:
Another option, using Scripting.Dictionary functionality:
Public Function getUnique(ByVal rngVals As Excel.Range) As Variant()
Dim objDictionary As Object
Dim rngRow As Excel.Range
Dim rngCell As Excel.Range
Dim strKey As String
Set objDictionary = CreateObject("Scripting.Dictionary")
For Each rngRow In rngVals.Rows
For Each rngCell In rngRow.Cells
strKey = strKey & "||" & rngCell.Text
Next rngCell
With objDictionary
If Not .Exists(Key:=Mid$(strKey, 3)) Then
Call .Add(Key:=Mid$(strKey, 3), Item:=Mid$(strKey, 3))
End If
End With
strKey = ""
Next rngRow
getUnique = objDictionary.Keys
Set rngVals = Nothing
Set rngRow = Nothing
Set rngCell = Nothing
End Function
Public Sub CountUnique()
Dim rngVals As Excel.Range
Dim varUnique() As Variant
Dim rngCell As Excel.Range
Dim varTemp As Variant
Set rngVals = Sheet3.Range("A2:B13").SpecialCells(12)
varUnique = getUnique(rngVals)
For Each rngCell In rngVals.Columns(2).Cells
varTemp = Filter(varUnique, rngCell.Text, True)
Debug.Print rngCell.Text, UBound(varTemp) - LBound(varTemp) + 1
Erase varTemp
Next rngCell
Set rngVals = Nothing
Set rngCell = Nothing
Erase varUnique
End Sub
I have a text string that is using the ^ symbol as a delimiter.
I need to separate the text into new rows rather than new columns.
I need to create new rows to not overwrite the next line of data below it.
Is this possible without using a macro? I'm not against using one, I just wouldn't know where to start to write it.
Below is a pic of some sample data. The top part is how it's listed, and the bottom (in yellow) is how I would like it.
Using Excel 2010 on Windows 7 Pro.
Thanks to those that responded. A friend was able to help by providing the following code:
Sub Breakout()
Application.ScreenUpdating = False
LR = Cells(Rows.Count, 1).End(xlUp).Row
For r = LR To 2 Step -1
Set MyCell = Cells(r, 1)
Arry = Split(MyCell.Value, "^")
For c = 0 To UBound(Arry)
If c > 0 Then MyCell.Offset(c, 0).EntireRow.Insert
MyCell.Offset(c, 0) = Arry(c)
Next c
Next r
End Sub
Could try something like this:
Sub reArrange()
Dim inFirstRng As Range
Dim inRng As Range
Dim inCur As Variant
Dim outFirstRng As Range
Dim outCurRng As Range
Dim ws As Worksheet
'CHANGE ARGUMENT TO YOUR SHEET NAME
Set ws = Worksheets("Sheet2")
With ws
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA INPUT IS IN COLUMN A
Set inFirstRng = .Range("A3")
Set inRng = .Range(inFirstRng, inFirstRng.End(xlDown))
'CHANGE ARGUMENT TO WHATEVER THE FIRST CELL OR YOUR DATA OUTPUT IS IN COLUMN A
Set outFirstRng = .Range("A9")
Set outCurRng = outFirstRng
End With
For Each cell In inRng.Cells
inCur = WorksheetFunction.Transpose(Split(cell.Value, "^"))
outCurRng.Resize(UBound(inCur), 1).Value = inCur
With ws
.Range("G" & outCurRng.Row & ":L" & outCurRng.Row).Value = _
.Range("G" & cell.Row & ":L" & cell.Row).Value
End With
Set outCurRng = outCurRng.Offset(UBound(inCur), 0)
Next cell
ws.Range("F" & outFirstRng.Row & ":F" & outCurRng.Row - 1).Value = 1
End Sub
I'm trying to create a macro using Excel 2007 for some data I've collected. What I need the macro do to is, search a column and find a certain number of consecutive zero's (60) and if there is 60 consecutive zero's delete them. Any advice or help would be really appreciated!
Is this what you are trying?
LOGIC:
Filter the range on the criteria
Store the address on the visible cells in a variable
Remove "$" which Excel automatically puts in the address
Check if the visible cell address is like "2:2" or "2:2,5:64"
Find the difference between the start row and end row
If difference is >= say 60 then clear contents.
CODE
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, times As Long, Col As Long, i As Long
Dim rRange As Range
Dim addr As String, MyArray() As String, tmpAr() As String, num As String
'~~> Change these as applicable
Set ws = ThisWorkbook.Sheets("Sheet1") '<~~ Sheet1
Col = 1 '<~~ Col A
num = "0" '<~~ Number to replace
times = 60 '<~~ Consecutive Cells with Numbers
'~~> Don't change anything below this
With ws
lRow = .Range(ReturnName(Col) & .Rows.Count).End(xlUp).Row
Set rRange = .Range(ReturnName(Col) & "1:" & ReturnName(Col) & lRow)
'~~> Remove any filters
.AutoFilterMode = False
'~~> Filter, offset(to exclude headers)
With rRange
.AutoFilter Field:=1, Criteria1:="=" & num
'~~> get the visible cells address
addr = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Address
End With
'~~> Remove any filters
.AutoFilterMode = False
addr = Replace(addr, "$", "")
'~~> Check if addr has multiple ranges
If InStr(1, addr, ",") Then
MyArray = Split(addr, ",")
'~~> get individual ranges
For i = LBound(MyArray) To UBound(MyArray)
tmpAr = Split(MyArray(i), ":")
'~~> If difference is >= times then clear contents
If Val(Trim(tmpAr(1))) - Val(Trim(tmpAr(0))) >= times - 1 Then
.Range(ReturnName(Col) & Trim(tmpAr(0)) & ":" & _
ReturnName(Col) & Trim(tmpAr(1))).ClearContents
End If
Next i
Else
tmpAr = Split(addr, ":")
If Val(Trim(tmpAr(1))) - Val(Trim(tmpAr(0))) >= times - 1 Then
.Range(ReturnName(Col) & Trim(tmpAr(0)) & ":" & _
ReturnName(Col) & Trim(tmpAr(1))).ClearContents
End If
End If
End With
End Sub
'~~~> Function to retrieve Col Names from Col Numbers
Function ReturnName(ByVal numb As Long) As String
ReturnName = Split(Cells(, numb).Address, "$")(1)
End Function
Though I have a feeling you are going to change the requirements after you run this...
Select all the cells you want to look at, then run this code:
Option Explicit
Sub deleteConsecutiveZeros()
Dim rng As Excel.Range
Dim countZeros As Long
Dim lastCellRow As Long
Dim iCurrentRow As Long
Set rng = Selection
lastCellRow = rng.Cells.SpecialCells(xlCellTypeLastCell).Row
For iCurrentRow = lastCellRow To 1 Step -1
If (countZeros >= 60) Then
ActiveSheet.Range(rng.Cells(iCurrentRow + 59, 1).Address, rng.Cells(iCurrentRow, 1).Address).EntireRow.Delete
countZeros = 0
End If
If (rng.Cells(iCurrentRow, 1).Value = 0 And rng.Cells(iCurrentRow, 1).Text <> vbNullString) Then
countZeros = countZeros + 1
Else
countZeros = 0
End If
Next
End Sub