Been awhile since I've done some programming and I'm not having much luck with a simple excel vba macro. I have data in a column and i need to select then delete the cells that do not contain a particular value. My data looks like this in a column:
990ppbAu/1,2
990ppbAu/0,5
990ppbAu/0,5
990ppbAu/0,3
9900ppmZr/29,1
9900ppmZn/5,2
9900ppmZn/1
9900ppmZn/0,8
9900ppmZn/0,5
9900ppmCu/2,8
I need to delete the values or strings that do not contain "Au" in them. Here is the start of my code, it's not much and probably wrong...but I'm hoping someone can point me in the right direction:
Option Explicit
Sub SearchColumn()
Dim strAu As String
Dim rngFound, rngDelete As Range
strAu = "*Au*"
'Search Column
With Columns("AF")
'Find values without "Au" in string in column AF and delete.
Set rngFound = .Find(strAu, .Cells(.Cells.Count), xlValues, xlWhole)
If rngFound <> strAu
'Then select the value and delete
'Else move onto the next cell until end of the document
End With
End Sub
I should note, some cells have nothing in them, while some have a string value as seen above. I need it to go through the entire column until end of document. There are about 115,000 records in the table. Thanks in advance!
Edited3 to delete cell content only
edited 2 make it delete single cell
edited to "reverse" the previous filtering criteria and keep cells containing "Au"
if your column has header then you can use this code:
Option Explicit
Sub SearchColumnWithHeader()
Dim strAu As String
strAu = "Au"
With ActiveSheet
With .Range("AF1", .Cells(.Rows.Count, "AF").End(xlUp))
.AutoFilter Field:=1, Criteria1:="<>*" & strAu & "*"
If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).ClearContents
End With
.AutoFilterMode = False
End With
End Sub
Related
I have a sheet FC, with this sheet, I have column R, S and T filled.
I would prefer to have a code, which checks if R contains "invalid" and if S and t are filled, then it should filter complete row.
I know we can use isblank function to check whether the cell is blank or not,
but I am struck how I can use a filter function with these condition .Any help will be helpful for me. I am struck how I can proceed with a vba code. Apologize me for not having a code.
You will have to somehow specify last row:
Dim lastRow, i As Long
For i = 1 To lastRow 'specify lastRow variable
If InStr(1, LCase(Range("R" & i).Value), "invalid") > 0 And Range("S" & i).Value = "" And Range("T" & i).Value = "" Then
'do work
End If
Next i
In our If condition we check three things that you asked.
Try this
Sub Demo()
Dim lastRow As Long
Dim cel As Range
With Worksheets("Sheet3") 'change Sheet3 to your data sheet
lastRow = .Cells(.Rows.Count, "R").End(xlUp).Row 'get last row in Column R
For Each cel In .Range("R5:R" & lastRow) 'loop through each cell in range R5 to lase cell in Column R
If cel.Value = "invalid" And Not IsEmpty(cel.Offset(0, 1)) And Not IsEmpty(cel.Offset(0, 2)) Then
cel.EntireRow.Hidden = True 'hide row if condition is satisfied
End If
Next cel
End With
End Sub
EDIT :
To unhide rows.
Sub UnhideRows()
Worksheets("Sheet3").Rows.Hidden = False
End Sub
Assuming Row1 is the header row and your data starts from Row2, in a helper column, place the formula given below.
This formula will return either True or False, then you may filter the helper column with either True or False as per your requirement.
=AND(R2="Invalid",S2<>"",T2<>"")
In case your header row is different, tweak the formula accordingly.
sub myfiltering()
'maybe first row always 4
firstrow=4
'last, maybe R column alaways have any entered info, so let us see what is the last
lastrow=cells(65000,18).end(xlup).row
'go ahead
for myrow=firstrow to lastrow
if cells(myrow,18)="Invalid" and cells(myrow,19)="" and cells(myrow,20)="" then
Rows(myrow).EntireRow.Hidden = True
else
Rows(myrow).EntireRow.Hidden = false
end if
next myrow
msgbox "Filter completed"
end sub
hope this will help you :)
Why you need the vba code for this problem?
Its more simple if you add a new column with if & and formula, and autofiltering within the added col.
The formula may be similar like this in the U2 cell.
=if(and(R2="invalid";S2="";T2="");"x";"")
Also set autofilter to x. :)
I have a worksheet containing data. As soon as something changes in a specific column, I want to copy the values of one column in this sheet to another worksheet, but only rows which match some criteria. So I have auto-filtered a range. This works. It only returns rows matching the filter. But from this filtered range, I only need one column. Somehow I cannot get this to work.
So my question would be, how can I only copy a specific column from a filtered range?
Code (snipped) I have so far:
Me.AutoFilterMode = False
With Me.Range("C4:D103")
.AutoFilter Field:=2, Criteria1:="=Marge Only", Operator:=xlOr, Criteria2:="=Contracting"
.SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Worksheets("Result").Range("B5:B104")
End With
ThisWorkbook.SortResult
On Error Resume Next
Me.AutoFilterMode = False
Me.ShowAllData
On Error GoTo 0
The .SpecialCells(xlCellTypeVisible).Copy part copies too much data to the destination worksheet. I need something like:
.Range("A:A").SpecialCells(xlCellTypeVisible).Copy
With .Range("A:A") my thought would be that only column A from the already filtered range would be copied. But this doesn't work.
So what would be your advice how to accomplish this?
You can modify your code slightly to copy only the column you need. This code assumes column A (but you can adjust) and it assumes row 4 is header data (you can also adjust.
With Me
.Range("C4:D103").AutoFilter Field:=2, Criteria1:="=Marge Only", Operator:=xlOr, Criteria2:="=Contracting"
.Range("A5:A103").SpecialCells(xlCellTypeVisible).Copy Destination:=ThisWorkbook.Worksheets("Result").Range("B5")
End With
Is this what you are talking about? It checks column "I" for the criterial then it finds the first and last cells in a filter "A" column and copies the values between the two and paste it in column "O"
Sub copyColumn()
Dim StrRow As Long
Dim str As String
Dim str2 As String
Dim str3 As String
With Sheet1
.AutoFilterMode = False
With .Range("A1:M1")
.AutoFilter
.AutoFilter Field:=9, Criteria1:="dog"
StrRow = Sheets("Sheet1").AutoFilter.Range.Offset(1).SpecialCells(xlCellTypeVisible).Cells(1, 2).Row
str = .Range("A" & StrRow).Address
str2 = .Range("A1").End(xlDown).Address
.Range("O2:O" & str3).Value = .Range(str, str2).Value
End With
End With
End Sub
I'm automating an update I have to do and part of the macro I want to write needs specific text from what gets populated.
I have the following types of text in the same column for hundreds of rows:
ScreenRecording^naushi02^procr^10035
procr^10635^ScreenRecording^misby01
ScreenRecording^liw03^procr^10046
I've bold the text I need. I want to either replace the whole text with just what I need or place what I need in the next column, same row.
I had wrote something which worked for 60 or so lines before I realised that there are variations in the format. For the main, it's all the same which is why I didn't realise at first and I've spent a lot of wasted time writing something that is now useless... so I'm asking for expert help please.
Once I've got what I need from the first row, I need to move down until the last entry repeating.
I had some code which obviously didn't work fully.
I have thought about using the text 'ScreenRecording' in a search along with the special character which I can't find on my keyboard and then trying to copy all text from that point upto and including the 2nd numerical character. I don't know how to do this, if it would work or even if it's a good idea but because I've spent so much time trying to figure it out, I need some help please.
Thanks in advance
If you always want to return the value after the word 'ScreenRecording`, you can use the following function to do so.
Include it in a SubRoutine to replace in place if needed:
Function SplitScreenRecording(sInput As String) As String
Dim a As Variant
Const SDELIM As String = "^"
Const LOOKUP_VAL As String = "ScreenRecording"
a = Split(sInput, SDELIM)
If IsError(Application.Match(LOOKUP_VAL, a, 0)) Then
SplitScreenRecording = CVErr(2042)
Else
SplitScreenRecording = a(Application.Match(LOOKUP_VAL, a, 0))
End If
End Function
Sub ReplaceInPlace()
Dim rReplace As Range
Dim rng As Range
Set rReplace = Range("A1:A3")
For Each rng In rReplace
rng.Value = SplitScreenRecording(rng.Value)
Next rng
End Sub
if you want to replace:
Sub main2()
Dim key As String
Dim replacementStrng As String
key = "ScreenRecording"
replacementStrng = "AAA"
With Worksheets("mysheet01").columns("A") '<--| change "mysheet01" and "A" to your actual sheet name and column to filter
.Replace what:=key & "^*^", replacement:=key & "^" & replacementStrng & " ^ ", LookAt:=xlPart
.Replace what:="^" & key & "^*", replacement:="^" & key & "^" & replacementStrng, LookAt:=xlPart
End With
End Sub
while if you want to place what you need in the next column:
Sub main()
Dim myRng As Range
Set myRng = GetRange(Worksheets("mysheet01").columns("A"), "ScreenRecording^") '<--| change "mysheet01" and "A" to your actual sheet name and column to filter
myRng.Offset(, 1) = "value that I need to place in next row" '<--| change the right part of the assignment to what you need
End Sub
Function GetRange(rng As Range, key As String) As Range
With rng
.AutoFilter Field:=1, Criteria1:="*" & key & "*" '<--| apply current filtering
If Application.WorksheetFunction.Subtotal(103, .Cells) > 0 Then '<--| if there are visible cells other than the "header" one
With .SpecialCells(xlCellTypeConstants)
If InStr(.SpecialCells(xlCellTypeVisible).Cells(1, 1), key & "^") > 0 Then
Set GetRange = .SpecialCells(xlCellTypeVisible) '<--|select all visible cells
Else
Set GetRange = .Resize(.Parent.Cells(.Parent.Rows.Count, .Column).End(xlUp).row - 1).Offset(1).SpecialCells(xlCellTypeVisible) '<--|select visible rows other than the first ("headers") one
End If
End With
End If
.Parent.AutoFilterMode = False '<--| remove drop-down arrows
End With
End Function
I am trying to add code to one of my worksheets that determines what the first column is with a value in it for each row (excluding the first column A because it is all headings). I have searched but cannot find anything that works for the FIRST occurrence in a row. Thank you for the help.
The following code will return the cell address of the first occurrence of data in a row for a set of columns.
It's unclear to me from your question, whether you want to look for the first occurrence of data in a row for a given column (what I wrote below), or the first occurrence of data in a column for a given row (if you need this, change the word Columns to the word Rows in the below code).
Sub FindFirstRowWithData()
With Worksheets("Sheet1")
Dim lCol As Long
For lCol = 2 To 10 'loop through columns B to J
Dim rngFound As Range
Set rngFound = .Columns(lCol).Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlNext)
If Not rngFound is Nothing then
Debug.Print rngFound.Address
Else
Msgbox "No Data in column " & lCol.
End If
Next
End With
End Sub
try this
Option Explicit
Sub FindFirstColumn()
Dim rngToScan As Range
Dim value As Variant
value = "a" '<== set it as the value of which first occurrence you want to search for
Set rngToScan = ActiveSheet.Range("B2:F100") '<== set it as the actual range of which columns will be searched the first occurrence of variable 'value'
With rngToScan
.Offset(, .Columns.Count).Resize(, 1).FormulaR1C1 = "=match(""" & value & """,RC2:RC" & .Columns(.Columns.Count).Column & ",0)"
End With
End Sub
I cant seem to find a solution for my application after endless searching. This is what I want to do:
I have cells in one excel sheet that can contain a mixture of dates and empty cells in one column. I want to then select the cells that have only dates and then copy them to a corresponding column in another sheet. They must be pasted in exactly the same order as in the first sheet because there are titles attached to each row. I do get it right with this code:
'Dim i As Long
'For i = 5 To 25
'If Not IsEmpty(Sheets("RMDA").Range("D" & i)) Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
'Next i
However, the dates in the first sheet are being updated on a daily basis and it can be that one title has not been updated (on another day) on the first sheet because the user has not checked it yet. If I leave it blank and If I follow the same procedure then it will "overwrite" the date in the second sheet and make the cell blank, which I do not want. I hope I was clear. Can someone please help me?
Regards
You can accomplish this very easily (and with little code) utilizing Excel's built-in AutoFilter and SpecialCells methods.
With Sheets("RMDA").Range("D4:D25")
.AutoFilter 1, "<>"
Dim cel as Range
For Each cel In .SpecialCells(xlCellTypeVisible)
Sheets("Overview").Range("D" & cel.Row).Value = cel.Value
Next
.AutoFilter
End With
you could try something like. This will give you the non blanks from the range, there may be an easier way... hope it helps
Sub x()
Dim rStart As Excel.Range
Dim rBlanks As Excel.Range
Set rStart = ActiveSheet.Range("d1:d30")
Set rBlanks = rStart.SpecialCells(xlCellTypeBlanks)
Dim rFind As Excel.Range
Dim i As Integer
Dim rNonBlanks As Excel.Range
For i = 1 To rStart.Cells.Count
Set rFind = Intersect(rStart.Cells(i), rBlanks)
If Not rFind Is Nothing Then
If rNonBlanks Is Nothing Then
Set rNonBlanks = rFind
Else
Set rNonBlanks = Union(rNonBlanks, rFind)
End If
End If
Next i
End Sub
Just because a cell is blank does not mean that it is actually empty.
Based on your description of the problem I would guess that the cells are not actually empty and that is why blank cells are being copied into the second sheet.
Rather than using the "IsEmpty" function I would count the length of the cell and only copy those which have a length greater than zero
Dim i As Long
For i = 5 To 25
If Len(Trim((Sheets("RMDA").Range("A" & i)))) > 0 Then _
Sheets("Overview").Range("D" & i) = Sheets("RMDA").Range("D" & i)
Next i
Trim removes all spaces from the cell and then Len counts the length of the string in the cell. If this value is greater than zero it is not a blank cell and therefore should be copied.