VBA - How to loop - vba

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.

Related

For each range including a variable-problem

I have a problem in a small part of my code : I want it to select the cells starting from c which is a cell meeting a condition that I have defined earlier, to the end of the list. In this range, I want it to copy the first value that exceeds resultat (a value obtained before).
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
Worksheets("Feuil1").Range(s1 & ":" & s2).Select
For Each Cel In Range(s1 & ":" & s2)
If Cel.Value >= resultat Then
firstValue = Cel.Value
firstAddress = Cel.Address
Exit For
End If
Next
Worksheets("Feuil1").firstValue.Copy
Range("C14").Worksheet("Feuil2").PasteSpecial
I get an error for the 2 first lines of the code.
Thanks a lot for your help.
This is my new code, because I realized something is missing.. The SearchRange does not start from row 2, but from the row where the value (a date) is equal to the last date of ws2. I get an error for my For each line. It says Object required.
Edit - New code, object error at rangyrange :
Private Sub CommandButton1_Click()
Dim rangyrange As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Dim firstAddress As String
Dim Cel As Range
Dim firstValue As Double
Dim A15Value As Date
Dim firsty As Long
Dim newRange As Range
Dim lastRow2 As Long
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Feuil1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Feuil2")
A15Value = CDate(ws2.Cells(15, 1).Value)
With ws1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastRow2 = .Cells(.Rows.Count, 2).End(xlUp).Row
Set foundRange = ws1.Range(.Cells(2, 1), .Cells(lastRow, 1))
Set searchRange = foundRange.Find(A15Value, LookIn:=xlValues)
Set rangyrange = ws1.Range(.Cells(searchRange.Row, 1), .Cells(lastRow, 1))
firsty = rangyrange.Rows(1).Row
Set newRange = ws1.Range(.Cells(firsty, 2), .Cells(lastRow2, 2))
End With
For Each ws1Cell In newRange
If ws1Cell.Value >= resultat Then
firstValue = ws1Cell.Value
firstAddress = ws1Cell.Address
Exit For
End If
Next
ws2.Cells(15, 3).Value = firstValue
End Sub
Dim c As Range
Worksheets("Feuil1").Range(Worksheets("Feuil1").Range(c), Worksheets("Feuil1").Range(c).End(xlDown))
You haven't set c to a range, so VBA doesn't understand what you're doing.
Also, I suggest defining a worksheet variable to increase the readability of your code like this:
Set ws = Excel.Application.Worksheets("Feuil1")
And your statement becomes much more legible:
ws.Range(ws.Range(c), ws.Range(c).End(xlDown))
This is not how you reference a range, also, I would suggest never using .Select.
Range(s1 & ":" & s2).Select
This is how you reference a range:
'this is my preferred method of referencing a range
Set someVariable = ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Or...
'this is useful in some instances, but this basically selects a cell
Set someVariable = ws.Range("B2")
Or...
'this references the range A1 to B1
Set someVariable = ws.Range("A1:B1")
Also, as #BigBen pointed out, you cannot set a range like so:
Dim c As Range
s1 = Worksheets("Feuil2").Range(c)
The reasons being:
c hasn't been assigned.
You can't use a range as an input unless it's of the form ws.Range(ws.Cells(row, column), ws.Cells(row, column))
Per your update that includes the assignment for c:
I get an error for the 2 first lines of the code.
This is because you're assigning c before you're declaring c.
You should have all of your Dim statements preceding your actual code (unless you know what you're doing) like so:
Public Sub MySub()
Dim c As Range
Dim firstAddress As String
Dim resultat As Double
Dim Cel As Range
Dim firstValue As Integer
Dim s1 As String, s2 As String
`the rest of your code
End Sub
I would change your Do loop to the following:
With Worksheets("Feuil1").Range("A2:A5181")
Set c = .Find(Worksheets("Feuil2").Range("A14").Value, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do While c.Address <> firstAddress
'I'm unsure of the goal here, so I'm ignoring it
Range(Range(c), Range(c).End(xlDown)).Select
If c Is Nothing Then
Exit Do
End If
Loop
End If
End With
Mainly because I hate GoTo statements and because the MS doc for Do loops states to use either Do While or Do Until instead of Loop While or Loop Until
s1 and s2 are strings, so you can't do this:
s1 = Worksheets("Feuil2").Range(c)
s2 = Worksheets("Feuil1").Range(s1).End(xlDown)
I'm assuming you want to get the column and row of c and iterate through that, but the problem is that you're working in 2 different worksheets, which you can't do. I'll assume it's an error and that you want to work on the "Fueil2" worksheet, so here goes:
Dim ws2 As Worksheet
Dim startCell As Range
Dim endCell As Range
Dim foundRange As Range
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Fueil2")
With ws2
Set startCell = .Cells(c.Row, c.Column)
Set endCell = .Cells(c.End(xlUp).Row, c.Column)
Set foundRange = .Range(.Cells(c.Row, c.Column), .Cells(c.End(xlUp).Row, c.Column))
For Each Cel In foundRange
'yada yada yada
End With
Post-lunch Edit:
It seems that this is a bit misleading because I tested this snippet and it works:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim foundRange As Range
Dim searchRange As Range
Dim workRange As Range
Dim foundColumn As Range
Dim ws1LastCell As Range
Dim ws1Range As Range
Dim iWantThis As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
Set searchRange = ws1.Range("A1:F1")
Set foundRange = searchRange.Find(ws2.Range("C1").Value, LookIn:=xlValues)
With foundRange
'last cell in the ws1 column that's the same column as foundRange
Set ws1LastCell = ws1.Range(ws1.Cells(.Row, .Column), ws1.Cells(ws1.Rows.Count, .Column)).End(xlDown)
'the range you want
Set iWantThis = ws1.Range(foundRange, ws1LastCell)
'check to see if it got what i wanted on ws1
iWantThis.Select
End With
End Sub
New Edit:
Public Sub test()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim c14Value As Double
Dim searchRange As Range
Dim lastRow As Long
Dim ws1Cell As Range
Set ws1 = Excel.Application.ThisWorkbook.Worksheets("Sheet1")
Set ws2 = Excel.Application.ThisWorkbook.Worksheets("Sheet2")
'gets the date
A14Value = CDate(ws2.Cells(14, 1).Value)
With ws1
'gets the last row's number in column A on worksheet 1
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'selects from A2 to the last row with data in it. this works only if
'there aren't any empty rows between your data, and that's what i'm assuming.
Set searchRange = .Range(.Cells(2, 1), .Cells(lastRow, 1))
End With
For Each ws1Cell In searchRange
If CDate(ws1Cell.Value) >= A14Value Then
'i didnt make a variable for firstValue
firstValue = ws1Cell.Value
'i didnt make a variable for firstAddress
firstAddress = ws1Cell.Address
Exit For
End If
Next
'puts firstValue into cell C14 on ws2
ws2.Cells(14, 3).Value = firstValue
End Sub
Until I see a definition for resultat, I'm assuming it's 100% correctly declared and assigned. hint: You should give us your declaration and assignment of resultat because I can't fully determine if how you defined resultat is an issue.

Search Column for Value from another Column

I am very new to VBA and I am trying to solve a problem to which I can't find the answer to on here.
I have 3 columns of data,
which you can see here:
I want to write a macro with which I can search the first fruit of column D in A. If the macro finds a match I want to copy the property of the fruit (B)(e.g. Vegetable) to E next to the corresponding name.
An example:
D6=Pineapple
search for pineapple in A and then copy B4 (Fruit) to E2.
Then continue with D3 (Avocado) doing the same procedure.
This is what I came up with so far. I know it is terrible and it doesn't work at all :')
Option Explicit
Sub fruits()
Dim fruit As String
Dim i As Integer
i = 1
Do While i < 20
Set fruit = Cells(i, "D").Value
If Not fruit Is Nothing Then
Set Cells(i, "E") = Columns(1).find(fruit.Value).Offset(0, 1).Text
End If
i = i + 1
Loop
End Sub
If you have any advice or solutions I would really appreciate it.
Sorry that I am posting such a 'trivial' question, but I really don't know how to.
Thanks, NiceRice
dim rng as range, rng2 as range, rcell as range, rcell2 as range
set rng = Thisworkbook.sheets("sheetName").range("d1:d3")
set rng2 = Thisworkbook.sheets("sheetName").range("a1:a8")
for each rcell in rng.cells
if rcell.value <> vbNullstring then
for each rcell2 in rn2.cells
If rcell.value = rcell2.value then
rcell.offset(0,1).value = rcell2.value
end if
next rcell2
end if
next rcell
pretty straight forward
I agree with Scott Craner, using Vlookup is the way to go, but I thought I would share a slightly different way to accomplish the same in VBA using the Find method:
Option Explicit
Sub fruits()
Dim LastRow As Long, LastARow As Long
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set your worksheet, amend as required
LastDRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
'get the last row with data on Column D
LastARow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
Dim rng As Range, c As Range, FoundVal As Range
Set rng = ws.Range("D1:D" & LastDRow)
For Each c In rng
Set FoundVal = ws.Range("A1:A" & LastARow).Find(What:=c.Value)
If Not FoundVal Is Nothing Then
c.Offset(0, 1).Value = FoundVal.Offset(0, 1).Value
End If
Next
End Sub

For Each Loop , Excel VBA

I have an excel file that is the outcome of a PDF to Excel conversion. The data in the excel file did not come clean for some of the columns.
What needs to be accomplished:
I have created a For Each loop to go over Column "B" and find the Auction Number. Once found, a second For Each loop was created to go over Column "E" and find the first occurrence of an address and cut this cell and move it to the same row of the auction number.
Problem:
The second for each loop keeps starting from the top of column "E" and not from where the for each loop row number in column "B" ended.
The Code is about 85% complete and no errors when running
Sub Macro1()
Dim rCell As Range
Dim rCell2 As Range
Dim rCell3 As Range
Dim rRng As Range
Dim rRng2 As Range
Dim rRng3 As Range
Dim i As Integer
Dim j As Integer
Dim strMyValue As String
Set rRng = Sheet2.Range("B:B")
Set rRng2 = Sheet2.Range("E:E")
Set rRng3 = Sheet2.Range("F:F")
i = 0
j = 0
For Each rCol In rRng.Columns
For Each rCell In rCol.Rows
If InStr(rCell.Value, "FEB") > 1 Then
i = rCell.Row
Debug.Print rCell.Address, rCell.Value, rCell.Row, i
For Each rCol2 In rRng2.Columns
For Each rCell2 In rCol2.Rows
If InStr(rCell2.Value, ", PA 1") > 1 Then
If InStr(Cells(rCell2.Row + 1, "E"), ", PA 1") = 0 Then
Debug.Print Cells(rCell2.Row + 1,"E").Value
Else
Cells(rCell2.Row + 1, "E").Clear
End If
rCell2.Cut Cells(rCell.Row, "D")
Exit For
End If
Next rCell2
Next rCol2
End If
Next rCell
Next rCol
End Sub
Appreciate any help. I just cant solve it ..
Can you try this? You have more loops than you need as your ranges are only single columns; also no need to iterate through all million rows, just the used bits.
Sub Macro1()
Dim rCell As Range
Dim rCell2 As Range
Dim rCell3 As Range
Dim rRng As Range
Dim rRng2 As Range
Dim rRng3 As Range
Dim rCol As Range
Dim rCol2 As Range
Dim i As Long
Dim j As Long
Dim strMyValue As String
With Sheet2
Set rRng = .Range("B1", .Range("B" & Rows.Count).End(xlUp))
Set rRng3 = .Range("F1", .Range("F" & Rows.Count).End(xlUp))
End With
For Each rCell In rRng
If InStr(rCell.Value, "FEB") > 1 Then
i = rCell.Row
Debug.Print rCell.Address, rCell.Value, rCell.Row, i
With Sheet2
Set rRng2 = .Range(.Cells(i, "E"), .Cells(.Rows.Count, "E").End(xlUp))
End With
For Each rCell2 In rRng2
If InStr(rCell2.Value, ", PA 1") > 1 Then
If InStr(rCell2.Offset(1), ", PA 1") = 0 Then
Debug.Print rCell2.Offset(1).Value
Else
rCell2.Offset(1).Clear
End If
rCell2.Cut rCell2.Offset(,-1)
Exit For
End If
Next rCell2
End If
Next rCell
End Sub
screen shot
Thanks SJR..
I attached a screen shot of the workbook. so far you have helped me in getting the loop working for each Auction Number in column "B" to go and find the address in column "E" and place it in column "D" on the same row of the auction No.
The problems that i am facing now are two.
1.having two addresses for that auction no.
2.Not having an address at all.
The solution the i have now with code will do the following:
getting only the first address and placing it correctly but leaving the other addresses. And if their is no address like for the auction number "003FEB18", the loop will pick up cell E21 "112 WASHINGTON PLACE UNIT 4A" and place it wrongfully on cell D13 for auction number "003FEB18"
For Each rCell In rRng
If InStr(rCell.Value, "FEB") > 1 Then
i = rCell.Row
'Debug.Print rCell.Address, rCell.Value, rCell.Row, i
With Sheet2
Set rRng2 = .Range(.Cells(i, "E"), .Cells(.Rows.count,
"E").End(xlUp))
End With
For Each rCell2 In rRng2
If InStr(rCell2.Value, ", PA 1") > 1 Then
rCell2.Cut Cells(rCell.Row, "D") 'rCell2.Offset(, -1)
Exit For
End If
Next rCell2
End If
Next rCell

Can't delete rows containing certain keyword within text

I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub

Searching three hyperlinks and outputting each on a new sheet

Looking in the Column "U" unit ( 1 ) and the opposite of that cell in the Column "E" extracting hyperlink, then paste it on a new sheet (and so each unit)
I wrote a program , but it does not give needed result .
Sub подготовительная()
Dim r As Range
Dim rng As Range
Dim book1 As Workbook
Dim str As String
Dim gbr As Range
Set book1 = Workbooks.Open("E:\...\Вопрос.xlsx")
'переходим в активную книгу на 1-ую страницу и выделяем диапозон
book1.Worksheets("7").Activate
Set rng = book1.Worksheets("7").Range("U33:U99")
'находим первую 1
Set r = rng.Find(What:="1")
'запоминаем 1-ый адресс
firstAddress = r.Address
'другая переменная
Set gbr = r.Offset(, -16)
'забираем гиперссылку
str = gbr.Hyperlinks.Item(1).Address
'вставляем в Лист1
book1.Worksheets("Лист1").Cells(1, 1).Value = str
'ищем вторую 1
book1.Worksheets("7").Activate
Set r = r.FindNext(r)
If r.Address <> firstAddress Then
Set gbr = r.Offset(, -16)
str = gbr.Hyperlinks.Item(1).Address
book1.Worksheets("Лист2").Cells(1, 1).Value = str
Else: Exit Sub
End If
'ищем третью 1
book1.Worksheets("7").Activate
Set r = r.FindNext(r)
If r.Address <> firstAddress Then
Set gbr = r.Offset(, -16)
str = gbr.Hyperlinks.Item(1).Address
book1.Worksheets("Лист3").Cells(1, 1).Value = str
Else: Exit Sub
End If
End Sub
I think your mistakes is in:
Set r = r.FindNext(r)
where you're trying to find the next occurrence if "1" in range r instead of rng
so you should use
Set r = rng.FindNext(r)
Furthermore you may want to shorten your code down with the use of a loop, a string array (where to store your three sheets names: "Лист1", "Лист2" and "Лист3") and some With statements, like follows:
Option Explicit
Sub main()
Dim r As Range
Dim firstAddress As String
Dim iLoop As Long
Dim sheetNames(1 To 3) As String
sheetNames(1) = "Лист1" '<--| change it with your actual 1st sheet name
sheetNames(2) = "Лист2" '<--| change it with your actual 2nd sheet name
sheetNames(3) = "Лист3" '<--| change it with your actual 3rd sheet name
With Workbooks.Open(E:\...\Вопрос.xlsx").Worksheets("7").Range("U33:U99") '<--| open wanted workbook and refer to cells "U33:U99" in its worksheet "7"
Set r = .Find(What:="1") '<--| the Find() method is called on the range referred to in the preceding With statement
If Not r Is Nothing Then
firstAddress = r.Address
Do
iLoop = iLoop + 1 '<-- update loop counter
.Parent.Parent.Worksheets(sheetNames(iLoop)).Cells(1, 1).value = r.Offset(, -16).Hyperlinks.item(1).Address '<--| write into proper worksheet whose name is taken from sheetNames array at index corresponding to current loop
Set r = .FindNext(r) '<--| the FindNext() method is still called on the same range as in the preceding .Find() statement
Loop While Not r Is Nothing And r.Address <> firstAddress And iLoop < 3 '<--| exit loop if either you hit the first link or completed three loops
End If
End With
End Sub