I have a list of product details in excel, headers in row 2, products details from row 3.
In column C, I have status of either Open or Closed and I want vba codes that can delete the whole range if the list is Open only, hence, no Closed if found. If data has both Closed and Open or just Closed, I don't have to do anything, just leave the data as it is.
This is part of the larger codes I have already written, so that is why I am hoping to achieve this using vba codes.
I am not sure if I need to set my range to column C and how to interpret rng.Cells(q, 1).Value. Right now it looks like my codes just step through and no error but nothing happens. I have provided pic of my test data and results.
Sub test()
Dim Satus As Worksheet
Dim LR1, q As Long
Dim rng As Range
Set Status = Worksheets("Sheet1")
LR1 = Status.Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Status.Range("B2:G" & LR1)
For q = 3 To LR1
If InStr(1, rng.Cells(q, 1).Value, "Closed") = 0 Then
Else
Status.Columns("B:G").EntireColumn.Delete
Status.Range("B2").Value = "No Closed Status"
End If
Next q
End Sub
It's much simpler by directly working with objects and using Excel's native functions:
Option Explicit
Sub Test()
Dim Status As Worksheet
Set Status = Worksheets("Sheet1")
With Status
Dim LR1 As Long
LR1 = .Range("B" & .Rows.Count).End(xlUp).Row
If .Range("C3:C" & LR1).Find("Closed", lookat:=xlWhole) Is Nothing Then
.Range("C3:C" & LR1).EntireRow.Delete
End If
End With
End Sub
Is Nothing is because .Find returns a range object if it's found. If it doesn't find it it will return, essentially, nothing.
It is simple to use Worksheetfunction countif.
Sub test()
Dim Satus As Worksheet
Dim LR1, q As Long
Dim rng As Range, rngDB As Range
Dim cnt As Long
Set Status = Worksheets("Sheet1")
With Status
LR1 = .Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Status.Range("B2:G" & LR1)
Set rngDB = .Range("c3:c" & LR1)
cnt = rngDB.Rows.Count
If WorksheetFunction.CountIf(rngDB, "Open") = cnt Then
rng.EntireColumn.Delete
.Range("B2").Value = "No Closed Status"
.Range("a1") = "Data1 Result"
End If
End With
End Sub
I think this should solve your problem. You can't decide in the for loop a state for a whole column. You have to collect all single states and execute a change afterwards.
Sub test()
Dim Satus As Worksheet
Dim LR1, row As Long
Dim rng As Range
'Dim lOpen As Long
Dim lClosed As Long
Set Status = ThisWorkbook.ActiveSheet
LR1 = Status.Cells(Rows.Count, "B").End(xlUp).row
Set rng = Status.Range("B2:G" & LR1)
rngStart = 2 ' because of header line
rngEnd = rng.Rows.Count - 1 ' likewise
For row = rngStart To rngEnd
Select Case rng.Cells(row, 2).Value
'Case "Open" ' just in case for future use
' lOpend = lOpend + 1
Case "Closed"
lClosed = lClosed + 1
Case Else
End Select
Next row
If lClosed = 0 Then
rng.EntireColumn.Delete ' delete just the data range
Status.Range("B2").Value = "No Closed Status"
End If
End Sub
I'm pretty new into this and I got stuck.
If I have a text string in column A (A1:A10) let's say. And I have a macro that looks for a keyword in that string, if it's found I want a word to be entered into column B (B1:B10).
For example A1-Pizza Hut - B1 Pizza, A2 Burger King - B2 Burger.
I got to the point where I can find the keyword, but when I try to do anything that would loop through the range, I always end up getting the same result in B.
Thank you for the answers. I thought I posted my code, but I guess it didn't. Anyways I figured out a way after looking online for the whole day.
Sub one()
Dim food As String, type As String
Dim rng As Range
Dim cel As Range
Set rng = Range("A:A")
For Each cel In rng
food = cel.Value
If InStr(UCase(food), UCase("pizza")) <> 0 Then
type = "Fast food"
Elseif InStr(UCase(food), UCase("burger")) <> 0 Then
type = "Fast food"
Else
type = "Not Fast food"
End If
cel.offset (0, 1).Value = type
Next cel
End Sub
Use a For Each Loop & Split:
Option Explicit
Public Sub Example()
Dim Sht As Worksheet
Dim rng As Range
Set Sht = ActiveWorkbook.Sheets("Sheet2")
For Each rng In Sht.Range("A1", Range("A11").End(xlUp))
rng.Offset(0, 1).Value = Split(rng, " ")(0)
Next
Set Sht = Nothing
Set rng = Nothing
End Sub
This should do what you want:
Sub Find_and_Copy():
Dim keywords() As Variant
keywords = Array("Pizza", "Burger", "Chicken")
Dim endRow As Integer
Dim SearchRng As Range
With Sheets("Sheet1")
endRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set SearchRng = .Range("A1:A" & endRow).Cells
End With
Dim r As Range
Dim firstAddress As String
Dim i As Integer
For i = 0 To UBound(keywords):
With SearchRng
Set r = .Find(keywords(i), LookIn:=xlValues)
If Not r Is Nothing Then
firstAddress = r.Address
Do
Cells(r.Row, "B").Value = keywords(i)
Set r = .FindNext(r)
Loop While Not r Is Nothing And r.Address <> firstAddress
End If
End With
Next
End Sub
It will find all occurrences of each entry in the 'keywords' array that matches cells of column "A" - and of course, set column "B" to that keyword.
Note that say you have an entry like "ala Burger Chicken" it'll put 'Chicken' (which I added to 'keywords' just to keep in the spirit of things) in column B for that row because that's the last thing it did a search for - hence overwriting the previous 'Burger' entry that was in that cell.
I need to find the row where a cell in column B contains two substrings.
For example these Strings in B1:B3
A string with Cows
Cows and stuff
A string with Chickens
I need to find the row B2where the 2 substrings Cows and shit are present.
What i tried so far:
Find formula that doesent do multiple search criteria. :(
=MATCH(1;INDEX((B:B="Cows")*(B:B="shit"););) that doesent do substrings
A lot other stuff i forgot,
If it is possible i would like a pure VBA solution.
Any ideas on this one?
http://www.mrexcel.com/forum/excel-questions/74933-matching-multiple-criteria-visual-basic-applications.html This is what you are looking for with your MATCH function.
The below will assign all values within column B to an array, and then assess each element of the array to see if it contains the strings "Cows" and "excrement".
To assess the string within the element, we use the InStr() Function.
Sub findStrings()
Dim wb As Workbook, ws As Worksheet
Dim arrValues() As Variant
Dim lrow As Long, i As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(1)
lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row
arrValues = Range(Cells(1, 2), Cells(lrow, 2))
For i = 1 To UBound(arrValues, 1)
If InStr(1, arrValues(i, 1), "Cows") Then
If InStr(1, arrValues(i, 1), "excrement") Then
MsgBox ("Cell " & Cells(i, 2).Address & " contains both strings.")
Exit Sub
End If
End If
Next i
End Sub
This will only find 1 match containing the strings you specify, if you require further matches then you will need a different solution.
This function returns range that contains all the cells having in its content both words given as parameters:
Public Function findCellsWithWords(firstWord As String, secondWord As String) As Excel.Range
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim rngFirst As Excel.Range
Dim rngSecond As Excel.Range
'--------------------------------------------------
Set wks = Excel.ActiveSheet
Set rng = wks.Columns(2).EntireColumn
Set rngFirst = findAll(rng, firstWord)
Set rngSecond = findAll(rng, secondWord)
Set findCellsWithWords = Excel.Intersect(rngFirst, rngSecond)
End Function
Public Function findAll(rng As Excel.Range, what As Variant) As Excel.Range
Dim rngResult As Excel.Range
Dim found As Excel.Range
Dim firstFound As String
'----------------------------------------------------------------------------
With rng
Set found = rng.Find(what)
Do Until found Is Nothing
If rngResult Is Nothing Then
firstFound = found.Address
Set rngResult = found
Else
Set rngResult = Excel.Union(rngResult, found)
End If
'Find next occurrence.
Set found = .FindNext(found)
If found.Address = firstFound Then Exit Do
Loop
End With
Set findAll = rngResult
End Function
I've created a form to reformat a report that I receive and I'm having an issue with automating part of it. Everything works until I define and set the last variable codelength which I want to set as the length of a cell (first column, second row) in a defined range. I receive run time error 424, "Object Required". I appreciate any help!!
Here is the code:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim rg As Range
Dim rgg As Range
Dim Addr1 As String
Dim Addr2 As String
'Get the address, or reference, from the RefEdit control.
Addr1 = RefEdit1.Value
Addr2 = RefEdit2.Value
'Set the SelRange Range object to the range specified in the
'RefEdit control.
Set rg = Range(Addr1)
Set rgg = Range(Addr2)
ActiveWorkbook.Names.Add Name:="codes", RefersTo:=rgg
'Infill
'Copies the value from the row above into blank cells.
Dim cel As Range, col As Range
Set rg = Range(Addr1).Columns(1).Resize(, 2)
On Error Resume Next
For Each col In rg.Columns
Set rgg = Nothing
Set rgg = col.SpecialCells(xlCellTypeBlanks)
If Not rgg Is Nothing Then
rgg.FormulaR1C1 = "=R[-1]C" 'Blank cells set equal to value from row above
rgg.Formula = rgg.Value 'Optional: Replace the formulas with the values returned by the formulas
End If
Next
Set rgg = rg.Offset(1, 0).Resize(rg.Rows.Count - 1, rg.Columns.Count)
For Each cel In rgg.Cells
If cel = "" Then cel.Value = cel.Offset(-1, 0).Value
Next
On Error GoTo 0
'ColCDeleter
Dim i As Long, n As Long
Set rg = Intersect(ActiveSheet.UsedRange, Range(Addr1).Columns(3))
n = rg.Rows.Count
For i = n To 1 Step -1
If rg.Cells(i, 1) = "" Then rg.Cells(i, 1).EntireRow.Delete
Next
'insert corresponding values
Dim codelength As Integer
codelength = Len(codes.Cells(2, 1).Value)
rg.Columns(2).EntireColumn.Insert
rg.Columns(2).EntireColumn.Insert
rg.Columns(2).EntireColumn.Insert
rg.Columns(2).EntireColumn.Insert
If codelength = 6 Then
rg.Columns(2).FormulaR1C1 = "=VLOOKUP((MID(RC1,9,9)),codes,2,FALSE)"
rg.Columns(3).FormulaR1C1 = "=VLOOKUP((MID(RC1,9,9)),codes,3,FALSE)"
Else
rg.Columns(2).FormulaR1C1 = "=VLOOKUP((MID(RC1,8,9)),codes,2,FALSE)"
rg.Columns(3).FormulaR1C1 = "=VLOOKUP((MID(RC1,8,9)),codes,3,FALSE)"
End If
rg.Cells(1, 2).Value = "Plan"
rg.Cells(1, 3).Value = "Status"
'Unload the userform.
Unload Me
End Sub
When you first name a range using the following syntax
Dim rng as Range
Set rng = Range("A1:A10")
ActiveWorkbook.Names.Add Name:="codes", RefersTo:=rng
Then this becomes just a name - it's not a stand alone object. So the error you are getting tells you exactly what is happening -> Object required.
To refer to the named Range you wrap it in double quotes and stick it as the parameter for the Range object. Therefore, Range("codes") creates a Range object referring to the rng Range.
An alternative, omitting the name would be to use the rng Range object simply replacing the Range("codes"). with rng.
I had some great help to get this search tool working in excel but I was wondering if there is room for speed improvement. I did some research and with what little I understand about VB for i = LBOUND(array) To UBOUND(array) seems most optimal. Would 'For Each' be faster? I am wondering if there is a way to isolate the records currently in the worksheet, or if it is already doing this with L/UBOUND? If it is, is there a way to do 'ignore special characters' similar to SQL? After adding screenupdating and calculation, I was able to shave about 10 seconds off of the total run time. And further I was using FormulaR1C1 for my search before this new loop and it would limit the amount of columns to search while being super fast.
Range("W2:W" & LastRow).FormulaR1C1 = _
"=IF(ISERR(SEARCH(R1C23,RC[-22]&RC[-21]&RC[-20]&RC[-19]&RC[-18]&RC[-17]&RC[-16]&RC[-15]&RC[-15]&RC[-14]&RC[-13]&RC[-12]&RC[-11]&RC[-10]&RC[-9]&RC[-8]&RC[-7]&RC[-6]&RC[-5]&RC[-4]&RC[-3]&RC[-2]&RC[-1])),0,1)"
If WorksheetFunction.CountIf(Columns(23), 1) = 0 Then
Columns(23).Delete
Any help or recommendations are greatly appreciated.
Sub FindFeature()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
Dim v As Variant
Dim vaDataCopy As Variant
Dim uRange As Range
Dim findRange As Range
Dim nxtRange As Range
Dim ws As Range
'Put all the data into an array
vaData = ActiveSheet.UsedRange.Value
'Get the search term
sSearchTerm = Application.InputBox("What are you looking for?")
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
Set uRange = ActiveSheet.UsedRange
vaData = uRange.Value
vaDataCopy = vaData
For Each v In vaDataCopy
v = Anglicize(v)
Next
Application.WorksheetFunction.Transpose (vaDataCopy)
ActiveSheet.UsedRange.Value = vaDataCopy
'Loop through the data
Set ws = Cells.Find(What:=uRange, After:="ActiveCell", LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not ws Is Nothing Then
Set findRange = ws
Do
Set nxtRange = Cells.FindNext(After:=ws)
Set findRange = nxtRange
Loop Until ws.Address = findRange.Address
ActiveSheet.UsedRange.Value = vaData
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, uRange(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Ultimately, the execution speed here is severely hampered by the apparent requirement to operate on every cell in the range, and because you're asking about performance, I suspect this range may contain many thousands of cells. There are two things I can think of:
1. Save your results in an array and write to the Results worksheet in one statement
Try replacing this:
'Write the row to the next available row on Results
Set rNext = shResults.Cells(shResults.Rows.Count, 1).End(xlUp).Offset(1, 0)
rNext.Resize(1, UBound(vaData, 2)).Value = Application.Index(vaData, i, 0)
'Stop looking in that row after one match
Exit For
With a statement that assigns the value Application.Index(vaData, i, 0) to an array variable, and then when you're completed the For i loop, you can write the results in one pass to the results worksheet.
NOTE This may be noticeably faster if and only if there are many thousands of results. If there are only a few results expected, then exeuction speed is primarily affected by the need to iterate over every cell, not the operation of writing the results to another sheet.
2. Use another method than cell iteration
If you can implement this method, I would use it in conjunction with the above.
Ordinarily I would recommend using the .Find and .FindNext methods as considerably more efficient than using the i,j iteration. But since you need to use the Anglicize UDF on every cell in the range, you would need to make some restructure your code to accommodate. Might require multiple loops, for example, first Anglicize the vaData and preserve a copy of the non-Anglicized data, like:
Dim r as Long, c as Long
Dim vaDataCopy as Variant
Dim uRange as Range
Set uRange = ActiveSheet.UsedRange
vaData = uRange.Value
vaDataCopy = vaData
For r = 1 to Ubound(varDataCopy,1)
For c = 1 to Ubound(varDataCopy,2)
varDataCopy(r,c) = Anglicize(varDataCopy(r,c))
Next
Next
Then, put the Anglicize version on to the worksheet.
ActiveSheet.UsedRange.Value = vaDataCopy
Then, instead of the For i =... For j =... loop, use the .Find and .FindNext method on the uRange object.
Here is an example of how I implement Find/FindNext.
Finally, put the non-Anglicized version back on the worksheet, again with the caveat that it might require use of Transpose function:
ActiveSheet.UsedRange.Value = vaData
Whil this still iterates over every value to perform the Anglicize function, it does not operate on every value a second time (Instr function). So, you're essentially operating on the values only once, rather than twice. I suspect this should be much faster, especially if you combine it with the #1 above.
UPDATE BASED ON OP REVISION EFFORTS
After some comment discussion & emails back and forth, we arrive at this solution:
Option Explicit
Sub FindFeature()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim shSearch As Worksheet:
Dim shResults As Worksheet
Dim vaData As Variant
Dim i As Long, j As Long, r As Long, c As Long
Dim sSearchTerm As String
Dim sData As String
Dim rNext As Range
Dim v As Variant
Dim vaDataCopy As Variant
Dim uRange As Range
Dim findRange As Range
Dim nxtRange As Range
Dim rng As Range
Dim foundRows As Object
Dim k As Variant
Set shSearch = Sheets("City")
shSearch.Activate
'Define and clear the results sheet
Set shResults = ActiveWorkbook.Worksheets("Results")
shResults.Range("A3").Resize(shResults.UsedRange.Rows.Count, 1).EntireRow.Delete
'# Create a dictionary to store our result rows
Set foundRows = CreateObject("Scripting.Dictionary")
'Get the search term
sSearchTerm = Application.InputBox("What are you looking for?")
'# set and fill our range/array variables
Set uRange = shSearch.UsedRange
vaData = uRange.Value
vaDataCopy = Application.Transpose(vaData)
For r = 1 To UBound(vaDataCopy, 1)
For c = 1 To UBound(vaDataCopy, 2)
'MsgBox uRange.Address
vaDataCopy(r, c) = Anglicize(vaDataCopy(r, c))
Next
Next
'# Temporarily put the anglicized text on the worksheet
uRange.Value = Application.Transpose(vaDataCopy)
'# Loop through the data, finding instances of the sSearchTerm
With uRange
.Cells(1, 1).Activate
Set rng = .Cells.Find(What:=sSearchTerm, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rng Is Nothing Then
Set findRange = rng
Do
Set nxtRange = .Cells.FindNext(After:=findRange)
Debug.Print sSearchTerm & " found at " & nxtRange.Address
If Not foundRows.Exists(nxtRange.Row) Then
'# Make sure we're not storing the same row# multiple times.
'# store the row# in a Dictionary
foundRows.Add nxtRange.Row, nxtRange.Column
End If
Set findRange = nxtRange
'# iterate over all matches, but stop when the FindNext brings us back to the first match
Loop Until findRange.Address = rng.Address
'# Iterate over the keys in the Dictionary. This contains the ROW# where a match was found
For Each k In foundRows.Keys
'# Find the next empty row on results page:
With shResults
Set rNext = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0). _
Resize(1, UBound(Application.Transpose(vaData), 1))
End With
'# Write the row to the next available row on Results
rNext.Value = Application.Index(vaData, k, 0)
Next
Else:
MsgBox sSearchTerm & " was not found"
End If
End With
'# Put the non-Anglicized values back on the sheet
uRange.Value = vaData
'# Restore application properties
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'# Display the results
shResults.Activate
End Sub
Public Function Anglicize(ByVal sInput As String) As String
Dim vaGood As Variant
Dim vaBad As Variant
Dim i As Long
Dim sReturn As String
Dim c As Range
'Replace any 'bad' characters with 'good' characters
vaGood = Split("S,Z,s,z,Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,D,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,d,n,o,o,o,o,o,u,u,u,u,y,y", ",")
vaBad = Split("Š,Ž,š,ž,Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ð,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ð,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ", ",")
sReturn = sInput
Set c = Range("D1:G1")
For i = LBound(vaBad) To UBound(vaBad)
sReturn = Replace$(sReturn, vaBad(i), vaGood(i))
Next i
Anglicize = sReturn
'Sheets("Results").Activate
End Function