I'm looking for some code to search through a range and return the row number of each cell in that range that fits a certain criteria and list those rows.
Previously I have only been requiring the first value so have been using the code:
Dim Criteria1 As Single
Dim Criteria2 As Single
Dim Required As Integer
Dim Range1 As Range
Dim GearNeg1 As Integer
SetColumn = 24
Set Range1 = Sheets("X").Range("A2:BT72").Columns(SetColumn).Cells
Criteria1 = Sheets("X").Range("P111").Value
Criteria2 = Sheets("X").Range("Q111").Value
For Each Cell In Range1
If Cell.Value < Criteria1 And Cell.Value > Criteria2 Then
Required = Cell.row
Exit For
End If
Next
I've been playing around with adding a for loop to return all the row values for the values that meet the criteria to a list. However am struggling and can only seem to hit the first value found every time.
You could read the range into an array, loop the array and concatenate qualifying rows into a string. I use the fact you start from row 2, and that I am using a 1 based array to determine the row i.e. I add 1 to the value of i which is the index in the array where the qualifying value is.
You could also use
required = required & "," & i + ws.Range("A2:BT72").Row - LBound(arr)
VBA:
Option Explicit
Public Sub test()
Dim criteria1 As Single, criteria2 As Single, required As String
Dim arr(), ws As Worksheet, setColumn As Long, i As Long
Set ws = ThisWorkbook.Worksheets("X")
setColumn = 24
arr = Application.Transpose(ws.Range("A2:BT72").Columns(setColumn).Value)
criteria1 = ws.Range("P111").Value
criteria2 = ws.Range("Q111").Value
For i = LBound(arr) To UBound(arr)
If arr(i) < criteria1 And arr(i) > criteria2 Then
required = required & "," & i + 1
End If
Next
required = Replace$(required, ",", vbNullString, 1, 1)
Debug.Print required
End Sub
This is a minimal example, returning the rows of the Range A1:A30, which are with X in them:
Public Sub TestMe()
Dim rowValues As String
Dim myCell As Range
For Each myCell In Worksheets(1).Range("A1:A30")
If myCell = "X" Then
rowValues = Trim(rowValues & " " & myCell.Row)
End If
Next myCell
Debug.Print rowValues
End Sub
The return is dones through concatenation here: rowValues = Trim(rowValues & " " & myCell.Row), the Trim() is needed to reduce the first " " on the first concatenation.
Related
Option Explicit
Public Function Vlookup2(ByVal Lookup_Value As String, ByVal Cell_Range As Range, ByVal Column_Index As Integer) As Variant
Dim cell As Range
Dim Result_String As String
On Error GoTo errHandle
For Each cell In Cell_Range
If cell.Value = Lookup_Value Then
If cell.Offset(0, Column_Index - 1).Value <> "" Then
If Not Result_String Like "*" & cell.Offset(0, Column_Index - 1).Value & "*" Then
Result_String = Result_String & ", " & cell.Offset(0, Column_Index - 1).Value
Exit Function
End If
End If
End If
Next cell
Vlookup2 = LTrim(Right(Result_String, Len(Result_String) - 1))
Exit Function
errHandle:
Vlookup2 = ""
End Function
I have the Function Vlookup and it goes through every cell from the top to the bottom, but I want it to go from bottom to top because that'll be faster. I'd be faster because the code will stop at a certain value and odds are that it'll find the value much faster if it starts from below rather than above
I'm answering this so that others, who have this question and come to this post, will have an example even if this isn't suitable or optimal for #Apples.
Sub Example()
'Loops through a range in reverse
'Significantly slower than UsingArrays (see below)
Dim ExampleRange As Range
Set ExampleRange = Sheet1.Range("A1:CA9999")
Dim i As Long, Cell As Range
For i = ExampleRange.Cells.Count To 1 Step -1
Set Cell = ExampleRange.Cells(i)
'Cell now refers to each individual cell within the range in reverse order!
Next i
End Sub
Sub UsingArrays()
'Copies Range to an Array
'Loops through the Array in reverse
Dim ExampleRange As Range
Set ExampleRange = Sheet1.Range("A1:CA9999")
Dim Values As Variant
Values = ExampleRange.Value
If IsArray(Values) Then
Dim i As Long, j As Long, Value As Variant
For i = UBound(Values) To LBound(Values)
For j = UBound(Values, 2) To LBound(Values, 2)
Value = Values(i, j)
'Value now refers to each individual cell's value in reverse order through the array
Next j
Next i
Else
MsgBox "This handles cases where ExampleRange is a single cell."
End If
End Sub
Sub SplitWords()
Dim TextStrng As String
Dim Result() As String
Sheets("CO REPORT").Select
TextStrng = Range("K6").Value
Result() = Split(TextStrng)
For i = LBound(Result()) To UBound(Result())
Sheets("RSVP SCOPE").Select
'ActiveSheet.ShowAllData
ActiveSheet.Range("$A$1:$G$791").AutoFilter Field:=1, Criteria1:="=*" &
Result(i) & "*", Operator:=xlOr
MsgBox Result(i)
Worksheets("RSVP SCOPE").Range("1:1").EntireRow.Hidden = True
Set Report = Excel.ActiveSheet
Dim visRng As Range
Set visRng = Report.UsedRange.SpecialCells(xlCellTypeVisible)
Dim r As Range
Dim j As Integer
For Each r In visRng.Rows
j = r.row
MsgBox (j)
Worksheets("RSVP SCOPE").Range("1:1").EntireRow.Hidden = False
ActiveSheet.Range("$A$1:$G$791").AutoFilter.ShowAllData
Next
Next i
End Sub
For the above code, the split words is being used since there will be multiple words in a single cell. I need to copy a text from sheet1 and search that value in column 1 of sheet2 . Now after filtering I need to display the row number for every selected words. In the above code, the first iteration gets executed successfully. But for the second iteration I get a
Your question is broken. I see trouble:
...
' Dim r As Range
Dim r As Variant
...
I'm trying to copy the values of a range of cells(A1:A50) into a single cell (B1). I can do it manually by copying the cells to the clipboard and then pasting the clipboard into the formuala bar of B1 but I can't find a way of doing this in a macro other than getting the cells copied to the clipboard.
Hopefully someone can help me out here.
Sheet1.Range("A1:A50").SpecialCells(xlCellTypeConstants).Select
Selection.Copy
I would like the contents of cell B1 to look something like this:
Value of cell A1
Value of cell A2
Value of cell A3
...and so on
Just
Sub myConcat(rSource As Range, rTarget As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
rTarget.Value = Right(sRes, Len(sRes) - Len(sDelimiter))
End Sub
Call it from your code like as
Sub tst_myConcat()
Call myConcat([A1:A50], [B1])
End Sub
Of course, this procedure can be easily converted to a function:
Function myConcat(rSource As Range, Optional sDelimiter = vbCrLf)
Dim oCell As Range
Dim sRes As String
sRes = vbNullString
For Each oCell In rSource
sRes = sRes & sDelimiter & oCell.Text
Next oCell
myConcat = Right(sRes, Len(sRes) - Len(sDelimiter))
End Function
In this case, just write in the target cell (B1) =myConcat(A1:A50)
Do not forget to include in the cell format Wrap text!
First Column To String
The FirstColumnToString function (UDF) has a fixed delimiter (Delimiter) which can manually be changed. But it can e.g. do the following:
=FirstColumnToString(A1:A2,A4,A6:C8,Sheet2!A1:A3)
where it will discard error values and zero-length strings ("") and choose only values from the first column of each range e.g. in range A6:C8 it will choose the values from A6:A8.
The Code
Option Explicit
Function FirstColumnToString(ParamArray SourceRanges() As Variant) _
As String
Const Delimiter As String = vbLf & vbLf
Dim RangesCount As Long
RangesCount = UBound(SourceRanges) - LBound(SourceRanges) + 1
Dim data As Variant
ReDim data(1 To RangesCount)
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Element As Variant
Dim RowsCount As Long
Dim j As Long
For Each Element In SourceRanges
j = j + 1
If Element.Rows.Count > 1 Then
data(j) = Element.Columns(1).Value
Else
data(j) = Help
data(j)(1, 1) = Element.Columns(1).Value
End If
RowsCount = RowsCount + UBound(data(j))
Next Element
Dim Result As Variant
ReDim Result(1 To RowsCount)
Dim Current As Variant
Dim i As Long
Dim k As Long
For j = 1 To RangesCount
For i = 1 To UBound(data(j))
Current = data(j)(i, 1)
If Not IsError(Current) Then
If Current <> vbNullString Then
k = k + 1
Result(k) = Current
End If
End If
Next i
Next j
ReDim Preserve Result(1 To k)
FirstColumnToString = Join(Result, Delimiter)
End Function
A much simpler way of doing the job is to use the TREXTJOIN function in Excel:
With Sheet2.Range("A1:A50")
.AutoFilter Field:=1, Criteria1:="<>"
Sheet2.Range("B1").Value2 = WorksheetFunction.TextJoin(vbCrLf, True, _
.SpecialCells(xlCellTypeVisible))
.AutoFilter
End With
I have a similar task as in there:
Copy value N times in Excel
But mine is a bit more complex.
So, I have this kind of sheet:
A B
dog-1.txt 3
cat-1.txt 2
rat-1.txt 4
cow-1.txt 1
The final result needs to be the following:
A
dog-1.txt
dog-2.txt
dog-3.txt
cat-1.txt
cat-2.txt
rat-1.txt
rat-2.txt
rat-3.txt
rat-4.txt
cow-1.txt
As you see it doesn't only multiply the cell content X times taken from column B, but it also increases the number in file name the same number of times with 1 step increase.
How could I achieve that?
Try the following (tried and tested):
Sub Extend()
Dim Rng As Range, Cell As Range
Dim WS As Worksheet, NewCell As Range
Dim Dict As Object, NewStr As String
Set WS = ThisWorkbook.Sheets("Sheet1") 'Modify as necessary.
Set Rng = WS.Range("A1:A5") 'Modify as necessary.
Set Dict = CreateObject("Scripting.Dictionary")
For Each Cell In Rng
If Not Dict.Exists(Cell.Value) Then
Dict.Add Cell.Value, Cell.Offset(0, 1).Value
End If
Next Cell
Set NewCell = WS.Range("C1") 'Modify as necessary.
For Each Key In Dict
For Iter = 1 To CLng(Dict(Key))
NewStr = "-" & Iter & ".txt"
NewStr = Mid(Key, 1, InStrRev(Key, "-") - 1) & NewStr
NewCell.Value = NewStr
Set NewCell = NewCell.Offset(1, 0)
Next Iter
Next Key
End Sub
Screenshot (after running):
The logic here is to get each name from the first column, store it as a dictionary key, then get the value beside it and store that that as the key-value. We then iterate inside each of the dictionary's keys, where we use the key-value as the upperbound of the iteration. During each iteration, we modify the string to change its number to the "current digit" of the iteration.
We choose C1 as the initial target cell. Every iteration, we offset it one (1) row below to accommodate the new/next iteration.
Let us know if this helps.
Tested , is this what u wanted :) ? (Working fine in my system)
Sub teststs()
Dim erange As Range
Dim lrow As Integer
Dim cnt As Integer
Dim rnt As Integer
Dim str As String
Dim lrow2 As Integer
With ActiveSheet
lrow = .Range("A" & Rows.Count).End(xlUp).Row ' finding the last row
For Each erange In .Range("A1:A" & lrow) ' loop though each each cell in the A column
cnt = erange.Offset(0, 1).Value
rnt = Mid(erange.Value, InStr(erange.Value, "-") + 1, 1)
For i = 1 To cnt 'Looping to cnt times
With Sheets("Sheet2")
lrow2 = .Range("A" & Rows.Count).End(xlUp).Row + 1
str = Replace(erange.Value, rnt, i, InStr(erange.Value, "-") + 1)
.Range("A" & lrow2).Value = Left(erange.Value, InStr(erange.Value, "-")) & str
End With
Next i
Next erange
End With
End Sub
I am working through my first VBA book and would appreciate if someone would point me in the right direction. How would I transfer a range of rows into a single cell with carriage returns? I would then like to repeat this action for all ranges in the column.
I think I need to:
find the first cell with a value in the column
verify that the next row is not empty
find the last cell in the range
perform "the operation" on the range
Following up on my comments. here is a very simple way to achieve what you want.
Option Explicit
'~~> You can use any delimiter that you want
Const Delim = vbNewLine
Sub Sample()
Dim rngInput As Range, rngOutput As Range
Application.ScreenUpdating = False
Set rngInput = Range("A1:A5") '<~~ Input Range
Set rngOutput = Range("B1") '<~~ Output Range
Concatenate rngInput, rngOutput
Application.ScreenUpdating = True
End Sub
Sub Concatenate(rng1 As Range, rng2 As Range)
Dim cl As Range
Dim strOutPut As String
For Each cl In rng1
If strOutPut = "" Then
strOutPut = cl.Value
Else
strOutPut = strOutPut & Delim & cl.Value
End If
Next
rng2.Value = strOutPut
End Sub
Within the context of a worksheet-level code, the following will work. Column 2 is hard-coded, so you might want to pass in a value or otherwise modify it to fit your needs.
Dim rng As Range
Set rng = Me.Columns(2)
Dim row As Integer
row = 1
' Find first row with non-empty cell; bail out if first 100 rows empty
If IsEmpty(Me.Cells(1, 2)) Then
Do
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2)) = False Or row = 101
End If
If row = 101 Then Exit Sub
' We'll need to know the top row of the range later, so hold the value
Dim firstRow As Integer
firstRow = row
' Combine the text from each subsequent row until an empty cell is encountered
Dim result As String
Do
If result <> "" Then result = result & vbNewLine
result = result & Me.Cells(row, 2).Text
row = row + 1
Loop Until IsEmpty(Me.Cells(row, 2))
' Clear the content of the range
Set rng = Me.Range(Me.Cells(firstRow, 2), Me.Cells(row, 2))
rng.Clear
' Set the text in the first cell
Me.Cells(firstRow, 2).Value2 = result