VBA code to select rows containing a word [duplicate] - vba

i'm writing a code and i'm stuck on this problem which i think should not bee too difficult to solve but i don't manage it.
I need my program to find all cells with a particular value and select them. But they should remain selected at the end of the sub.
So i changed a bit a code i found on the web and wrote that:
Sub FindAll()
With Worksheets(4).Range("a1:l500")
Set c = .Find("myValue", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Worksheets(4).Range(c.Address).Activate
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Of course it selects them in sequence but they do not remain selected, so at the end i just have the last found cell selected
Can anyone help me solve that?
Thanks in advance

Use the Union method to collect the ranges into one discontiguous range then .Select them before leaving the sub
Sub FindAll()
Dim firstAddress As String, c As Range, rALL As Range
With Worksheets(4).Range("a1:l500")
Set c = .Find("myValue", LookIn:=xlValues)
If Not c Is Nothing Then
Set rALL = c
firstAddress = c.Address
Do
Set rALL = Union(rALL, c)
Worksheets(4).Range(c.Address).Activate
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
.Activate
If Not rALL Is Nothing Then rALL.Select
End With
End Sub

As #Jeeped has already answered, using the Union Method will achieve what you were after.
If the range you were searching for values within was to increase, it would be more efficient to use an Array to hold the values; you can then search the array instead of the worksheet.
Just something to think about for the future.
Option Explicit
Sub arrayFindAll()
Dim wb As Workbook, ws As Worksheet
Dim myArr() As Variant, myCells() As Integer
Dim i As Long, j As Integer, k As Integer, m As Integer
Dim valOccurence As Integer
Dim unionCells As Range, lookupRng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets(4)
Set lookupRng = ws.Range("A1:L500")
myArr = lookupRng
valOccurence = WorksheetFunction.CountIf(lookupRng, "myValue") - 1
ReDim myCells(0 To valOccurence, 0 To 1)
For i = LBound(myArr, 1) To UBound(myArr, 1)
For j = LBound(myArr, 2) To UBound(myArr, 2)
If myArr(i, j) = "myValue" Then
For k = 0 To UBound(myCells, 1)
If myCells(k, 0) = 0 Then
myCells(k, 0) = i
myCells(k, 1) = j
Exit For
End If
Next k
End If
Next j
Next i
Set unionCells = Cells(myCells(m, 0), myCells(m, 1))
For m = 1 To valOccurence
Set unionCells = Union(unionCells, Cells(myCells(m, 0), myCells(m, 1)))
Next m
unionCells.Select
End Sub

Related

Excel VBA: Locking range of cells

Im trying to lock a few ranges of cells to prevent them from being altered outside of the button press.
I have the following code so far:
Private Sub DateRangePayer()
Dim unionRange As Range, uRng As Range, EssentialWrite As Range, chCell As Range, chRng As Range
Dim d As Long, k As Long, x As Long
ActiveSheet.Unprotect
Set EssentialWrite = Sheets("Essential Info").Range("E2:E6")
Set unionRange = ActiveSheet.Range("Q8:R12, T8:T12, Q16:R20, T16:T20")
Set chRng = ActiveSheet.Range("Q8:R12, T8:T12, Q16:R20, T16:T20")
x = Sheets("Essential Info").Range("G19").Value
ReDim OArr(1 To 5, 1 To 1) As Variant
For d = DateSerial(Year(x), Month(x), 1) To DateSerial(Year(x), Month(x) + 1, 0) - 1
If Weekday(d, vbSunday) = 7 Then
k = k + 1
OArr(k, 1) = d
End If
Next d
If k = 4 Then OArr(k + 1, 1) = "-"
For Each uRng In unionRange.Areas
uRng.Value = OArr
uRng.NumberFormat = "dd-mmmm"
Next uRng
For Each chCell In chRng.Cells
chCell.MergeArea.Locked = (chCell.Value <> "")
Next chCell
EssentialWrite.Value = OArr
EssentialWrite.NumberFormat = "dd-mmmm"
ActiveSheet.Protect
End Sub
The main parts of the code are the
ActiveSheet.Unprotect
For Each chCell In chRng.Cells
chCell.MergeArea.Locked = (chCell.Value <> "") Next chCell
ActiveSheet.Protect
Currently the code executes with zero errors. However the range of cells is not locked at all and is actually editable in its entirety.
Im doing this to prevent unexpected user entries in the specified cells
Any advice on what may work.
Im sorry if the code is a little messy. Im kinda just hacking together at this point and relatively new to this
This code locks only the code that say LOCKED in the image below.
Sub lockCells()
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
ws.Cells.Locked = False
Dim rng As Range
Set rng = ws.Range("A1:A10")
Dim cell As Range
For Each cell In rng
cell.Locked = cell.Value <> ""
Next cell
ws.Protect 1234
End Sub
I'm not sure this is 'best practice' but I'd use:
chCell.Cells(1, 1).Locked = (chCell.Value <> "")

Range.FindNext causing a runtime error 91

I am using VBA to search a 15x15 array for the location (row and column number) of all the '1's and map them to a new location.
Sub findvalues()
Dim OldRow As Long
Dim OldColumn As Long
With Worksheets(1).Range("a1:o15")
Set c = .Find(1, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
cellAddress = c.Address
OldRow = Range(cellAddress).Row
OldCol = Range(cellAddress).Column
MsgBox (OldRow)
With Worksheets(1).Range("r3:r16")
Set oldmapping = .Find(OldRow, LookIn:=xlValues, LookAt:=xlWhole)
NewCol = oldmapping.Offset(, 1).Value
MsgBox (NewCol)
End With
Set c = .FindNext(c)
MsgBox (c.Address)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
The strange thing is, the code runs fine until the fourth loop where it gets to MsgBox (c.Address) and throws a
runtime error 91 - object variable not set
I have a feeling it is down to the Set c = .FindNext(c) on the line previous but can't figure out why as it works fine for the first 3 loops.
The .FindNext derived from,
Set c = .Find(1, LookIn:=xlValues)
... is being superseded by the intermediate,
Set oldmapping = .Find(OldRow, LookIn:=xlValues, LookAt:=xlWhole)
Your .FindNext and loop conditions are no longer valid.
Switch to an alternate method for the second .Find.
Option Explicit
Sub findvalues()
Dim OldRow As Long, OldCol As Long, NewCol As Long
Dim oldmapping As Variant, c As Range, firstAddress As String, cellAddress As String
With Worksheets(1).Range("a1:o15")
Set c = .Find(1, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
cellAddress = c.Address
OldRow = Range(cellAddress).Row
OldCol = Range(cellAddress).Column
MsgBox (OldRow)
oldmapping = Application.Match(OldRow, Worksheets(1).Range("r3:r16"), 0)
If Not IsError(oldmapping) Then
NewCol = Worksheets(1).Range("r3:r16").Cells(oldmapping).Offset(, 1).Value
MsgBox NewCol
End If
Set c = .FindNext(c)
MsgBox (c.Address)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
A loop while (or do while) will still run once when the test is true, here is a simple example:
Sub temp()
Dim X As Long
X = 0
Do
X = X + 1
Debug.Print X
Loop While X < 5
End Sub
Notice 5 shows up in the list of values in your debug window.
A simple test should fix this up for you.
If Not c Is Nothing then MsgBox (c.Address)
or you could tell it to exit the loop if c is nothing, your choice

VBA Looping Through Multiple Worksheets

I am working on building code which can loop through a column (B5:B) on multiple worksheets to find matching values. If the Value on one worksheet's column (B5:B) is equal to a worksheet name, then the worksheet name is placed on the adjacent column (C5:C) to where the value was found. I am not a programmer, but I've been learning VBA to make this happen. So far I have tried unsuccessfully to use the For Next Loop (starting with the 3rd sheet), the For Each ws in Thisworkbook.sheets method. But I don't seem to be able to make it work. I've searched all over the internet for something similar, but no dice. Any suggestions would be greatly appreciated.
Sub MatchingPeople()
Dim c As Variant
Dim lastrow As Long
Dim i As Variant
Dim g As Long
Dim w As Long
i = Sheets("Anthony").Name
g = Sheets("Anthony").Cells(Rows.Count, "C").End(xlUp).Row
For w = 3 To Sheets.Count
lastrow = Sheets(w).Cells(Rows.Count, 2).End(xlUp).Row
Set NewRang = Sheets("Anthony").Cells(g + 1, 3)
On Error Resume Next
With Sheets(w).Range(Cells(5, 2), Cells(lasty, 2))
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
firstaddress = c.Address
Do
NewRang.Value = Sheets(w).Name
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
End With
Next w
End Sub
Here are 2 versions, one using the Find method like in your code, the other using a For loop
Option Explicit
Public Sub MatchingPeopleFind()
Dim i As Long, lrColB As Long
Dim wsCount As Long, wsName As String
Dim found As Variant, foundAdr As String
wsCount = Worksheets.Count
If wsCount >= 3 Then
For i = 3 To wsCount
With Worksheets(i)
wsName = .Name
lrColB = .Cells(.Rows.Count, 2).End(xlUp).Row
With .Range(.Cells(5, 2), .Cells(lrColB, 2))
Set found = .Find(wsName, LookIn:=xlValues)
If Not found Is Nothing Then
foundAdr = found.Address
Do
found.Offset(0, 1).Value2 = wsName
Set found = .FindNext(found)
Loop While Not found Is Nothing And found.Address <> foundAdr
End If
End With
End With
Next
End If
End Sub
Public Sub MatchingPeopleForLoop()
Dim wsCount As Long, wsName As String, i As Long, j As Long
wsCount = Worksheets.Count
If wsCount >= 3 Then
For i = 3 To wsCount
With Worksheets(i)
wsName = .Name
For j = 5 To .Cells(.Rows.Count, 2).End(xlUp).Row
If .Cells(j, 2).Value2 = wsName Then .Cells(j, 3).Value2 = wsName
Next
End With
Next
End If
End Sub
Sub Bygone()
Dim x As Long
Dim y As Long
Dim z As Long
Dim w As Long
Dim a As Long
Dim b As Long
Dim c As Long
Dim m As Long
a = Sheets.Count
For m = 3 To a
x = Sheets(m).Cells(3, 3).Value
For b = 3 To a
w = Sheets(b).Cells(Rows.Count, 1).End(xlUp).row
For z = 5 To w
y = Sheets(b).Cells(z, 1)
Select Case x
Case y
c =Sheets(m).Cells(Rows.Count,3).End(xlUp).Offset(1, 0).row
Sheets(m).Cells(c, 3).Value = Sheets(b).Name
End Select
Next z
Next b
Next m
End Sub

how to change output location for each loop and run multiple loops

I have code here which loops through a list of files; opening them, extracting data and moving it into the main workbook. What i am looking to do get it so the data for abel is in columns c and d but then put varo in f and g etc. the problem that i see is that the placement code is inside the loop so for each i it will just write over the previous line instead of being in a different column all together!
Sub Source_Data()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
ReDim findValues(1 To 3)
findValues(1) = "abel"
findValues(2) = "varo"
findValues(3) = "Tiger"
counter = 0
r = Range("A1").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 2).Value
Do
This.Activate
tmp.Offset(0, 2).Value = tmp.Value
tmp.Offset(0, 3).Value = firstAddress
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
Wrbk.Close
Next tmp
End Sub
**EDIT:**I know it can be done by adding a multiplier of "i" to the offset value but this makes things bigger than they need to be if i wish to search for 50 keywords
Here is my answer, hope to help you, and as always, if you need an improvement, just tell me.
Sub Source_Data()
Dim r
Dim findValues() As String
Dim Wrbk As Workbook
Dim This As Workbook
Dim sht As Worksheet
Dim i
Dim tmp
Dim counter
Dim c As Range
Dim firstAddress
Dim rng As Range
Dim ColNum 'the columns number var
ReDim findValues(1 To 3)
findValues(1) = "abel"
findValues(2) = "varo"
findValues(3) = "Tiger"
counter = 0
r = Range("A1").End(xlDown).Row
Set rng = Range(Cells(1, 1), Cells(r, 1))
Set This = ThisWorkbook
For Each tmp In rng
Workbooks.Open tmp
Set Wrbk = ActiveWorkbook
Set sht = ActiveSheet
For i = 1 To 3
With sht.Range(Cells(1, 1), Range("A1").SpecialCells(xlCellTypeLastCell))
Set c = .Find(findValues(i), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Offset(0, 2).Value
Do
This.Activate
Select Case i 'Test var i (the value)
Case "abel" 'in case the value (that is a string) is equal to...
ColNum = 1 'set the var, with the number of the column you want
Case "varo" 'in case the value...
ColNum = 2 'Set the column...
Case "Tiger"
ColNum = 3
Case Else 'In case that the i var not match with anyvalue take this column number
ColNum = 20 'the garbage!
End Select
tmp.Offset(0, ColNum).Value = tmp.Value 'Put the value in the selected columns
tmp.Offset(0, ColNum + 1).Value = firstAddress 'and put the value to the next column of the
'selected column
Set c = .FindNext(c)
counter = counter + 1
Loop While Not c Is Nothing And c.Value = firstAddress
End If
End With
Wrbk.Activate
Next
Wrbk.Close
Next tmp
End Sub
Note:
You need to set the ColNum var to the values that you need, put there the numbers of the columns you really need to store the value of i and the next line is to put the address of the i var
You can just change these two lines:
tmp.Offset(0, 2).Value = tmp.Value
tmp.Offset(0, 3).Value = firstAddress
To this
tmp.Offset(0, 2 + (i-1)*2).Value = tmp.Value
tmp.Offset(0, 3 + (i-1)*2).Value = firstAddress

VBA-Excel find and select multiple cells

i'm writing a code and i'm stuck on this problem which i think should not bee too difficult to solve but i don't manage it.
I need my program to find all cells with a particular value and select them. But they should remain selected at the end of the sub.
So i changed a bit a code i found on the web and wrote that:
Sub FindAll()
With Worksheets(4).Range("a1:l500")
Set c = .Find("myValue", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Worksheets(4).Range(c.Address).Activate
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
Of course it selects them in sequence but they do not remain selected, so at the end i just have the last found cell selected
Can anyone help me solve that?
Thanks in advance
Use the Union method to collect the ranges into one discontiguous range then .Select them before leaving the sub
Sub FindAll()
Dim firstAddress As String, c As Range, rALL As Range
With Worksheets(4).Range("a1:l500")
Set c = .Find("myValue", LookIn:=xlValues)
If Not c Is Nothing Then
Set rALL = c
firstAddress = c.Address
Do
Set rALL = Union(rALL, c)
Worksheets(4).Range(c.Address).Activate
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
.Activate
If Not rALL Is Nothing Then rALL.Select
End With
End Sub
As #Jeeped has already answered, using the Union Method will achieve what you were after.
If the range you were searching for values within was to increase, it would be more efficient to use an Array to hold the values; you can then search the array instead of the worksheet.
Just something to think about for the future.
Option Explicit
Sub arrayFindAll()
Dim wb As Workbook, ws As Worksheet
Dim myArr() As Variant, myCells() As Integer
Dim i As Long, j As Integer, k As Integer, m As Integer
Dim valOccurence As Integer
Dim unionCells As Range, lookupRng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets(4)
Set lookupRng = ws.Range("A1:L500")
myArr = lookupRng
valOccurence = WorksheetFunction.CountIf(lookupRng, "myValue") - 1
ReDim myCells(0 To valOccurence, 0 To 1)
For i = LBound(myArr, 1) To UBound(myArr, 1)
For j = LBound(myArr, 2) To UBound(myArr, 2)
If myArr(i, j) = "myValue" Then
For k = 0 To UBound(myCells, 1)
If myCells(k, 0) = 0 Then
myCells(k, 0) = i
myCells(k, 1) = j
Exit For
End If
Next k
End If
Next j
Next i
Set unionCells = Cells(myCells(m, 0), myCells(m, 1))
For m = 1 To valOccurence
Set unionCells = Union(unionCells, Cells(myCells(m, 0), myCells(m, 1)))
Next m
unionCells.Select
End Sub