Insert multiple cell values to a comment - excel

I have a task to add a comment in a sumtotal by month to show the items involved and the amount. I Want to simplify the works because Ido it by monthly and every job (over 20 jobs)!
I found solutions for a single cell.
I need to add related cell values to one comment for the month.
Option Explicit
Sub CreateComment()
Dim rng As Range
Dim cel As Range
Dim myColumn, myRow As Integer
Set rng = Selection
myColumn = ActiveCell.Column
myRow = ActiveCell.Row
For Each cel In rng
If cel.Value <> "" Then
Range("myColumn" & "1").AddComment [Cell("myRow", "1")).Value & " -$" & Cell("myRow","myColumn")_.value]
End If
Next
End Sub

Add Comments to a Range
Option Explicit
Sub AddComments()
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim lCol As Long: lCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
Dim srg As Range: Set srg = ws.Range("A1").Resize(lRow, lCol)
Dim Data As Variant: Data = srg.Value
Dim r As Long, c As Long, n As Long
Dim Comm As String
For c = 2 To lCol
For r = 4 To lRow
If Len(Data(r, c)) > 0 Then
n = n + 1
Comm = Comm & n & ". " & Data(r, 1) & " - " _
& Format(Data(r, c), "$#,##0") & vbLf
End If
Next r
If n > 0 Then
With srg.Cells(1, c)
.ClearComments
.AddComment Left(Comm, Len(Comm) - 1)
End With
n = 0
Comm = ""
End If
Next c
MsgBox "Comments added.", vbInformation
End Sub

Related

How to use Evaluate instead of for each Loop?

I need to know How to use Evaluate instead of for each Loop ? as in below simple code:
Sub Loop_Range_2()
Dim cel As Range, counter As Long
For Each cel In Range("A1:D5")
counter = counter + 1
cel = counter
Next
End Sub
In advance, thanks for all your help.
For Each...Next vs Worksheet.Evaluate vs Array
Here is a benchmark setup that shows that using an array is in general the most efficient way.
I only could figure out an Evaluate version by looping through the rows of the range and using ROW function. Note its limitation of 1048576 rows (1024*1024 or 10^20) . The fewer rows, the faster the solution. At the current setup, it is even more efficient than the array version.
Option Explicit
Private Const rCount As Long = 64
Private Const cCount As Long = 16384
Private dT As Double
Sub Loop_Range_2()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").Resize(rCount, cCount)
dT = Timer
Dim cel As Range, n As Long
For Each cel In rg.Cells
n = n + 1
cel.Value = n
Next
Debug.Print "For Each...Next Loop = " & Format(Timer - dT, "00.000000") _
& vbTab & rCount & vbTab & cCount
End Sub
Sub EvaluateRow()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").Resize(rCount, cCount)
Dim rrg As Range, c As Long
dT = Timer
For Each rrg In rg.Rows
c = c + 1
rrg.Value = Application.Transpose(ws.Evaluate( _
"ROW(" & (c - 1) * cCount + 1 & ":" & c * cCount & ")"))
Next rrg
Debug.Print "Evaluate Row = " & Format(Timer - dT, "00.000000") _
& vbTab & rCount & vbTab & cCount
End Sub
Sub ArrayLoop()
Dim ws As Worksheet: Set ws = ActiveSheet
Dim rg As Range: Set rg = ws.Range("A1").Resize(rCount, cCount)
Dim Data() As Variant: ReDim Data(1 To rCount, 1 To cCount)
Dim r As Long, c As Long, n As Long
Dim dT As Double: dT = Timer
For r = 1 To rCount
For c = 1 To cCount
n = n + 1
Data(r, c) = n
Next c
Next r
rg.Value = Data
Debug.Print "Array Loop = " & Format(Timer - dT, "00.000000") _
& vbTab & rCount & vbTab & cCount
End Sub

How to speed data copy from sheet1 to Other sheets by using Arrays, Excel vba?

I have workbook with three sheets.
I copy data from sheet1 to sheet2 & sheet3 depend on specific condition on sheet1, value = "Yes" on columns T or U.
The below code works fine using for Loop, but it is slow.
Now I transferred all data of sheet1 to array .
MyArray = Sheet1.Range("A3:U" & LastRow).Value2
is it possible to copy data from this array (by condition if specific value on it) to the other sheets .
I am new to vba , so any help will be appreciated .
Sub Copy_Data_On_Condition()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ris_column As Range
Dim cell As Object
Dim DestRng As Range
Dim MyArray() As Variant
LastRow = Sheet1.Cells(Rows.count, 1).End(xlUp).Row
MyArray = Sheet1.Range("A3:U" & LastRow).Value2
Set ris_column = Sheet1.Range("T3:T" & LastRow)
For Each cell In ris_column
If cell.value = "Yes" Then
Set DestRng = Sheet2.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
cell.EntireRow.Copy DestRng
End If
Next cell
Set ris_column = Sheet1.Range("U3:U" & LastRow)
For Each cell In ris_column
If cell.value = "Yes" Then
Set DestRng = Sheet3.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
cell.EntireRow.Copy DestRng
End If
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Update: Both two answers works perfectly , I tested on a sheet with total 2180 rows and copied rows about 1200. "FaneDure" Code takes about 4 second to finish and "Super Symmetry" code takes 0.07 of second which is significantly faster .
Please, try the next code:
Sub Copy_Data_On_Condition()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, LastRow As Long
Dim arr_column, rngT As Range, rngU As Range, i As Long, lastCol As Long
Set sh1 = Sheet1: Set sh2 = Sheet2: Set sh3 = Sheet3 'only to make the code more compact
LastRow = sh1.cells(rows.count, 1).End(xlUp).row 'last row in A:A column
lastCol = sh1.UsedRange.Columns.count 'last column of Sheet1, to avoid copying the whole row
arr_column = sh1.Range("T3:U" & LastRow).Value2 'put in an array the columns to be processed against "Yes" string
'process both columns in the same iteration to make code faster
For i = 1 To UBound(arr_column) 'iterate between the array rows and process the columns values
If arr_column(i, 1) = "Yes" Then 'finding a match in column T:T:
If rngT Is Nothing Then 'if the rngT keeping the range to be copied is not Set (yet)
Set rngT = sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol)) 'the range is Set by the used range suitable row
Else
Set rngT = Union(rngT, sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol))) 'add the suitable row to the existing range
End If
End If
If arr_column(i, 2) = "Yes" Then 'finding a match in column U:U:
If rngU Is Nothing Then 'if the rngU keeping the range to be copied is not Set (yet)
Set rngU = sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol)) 'the range is Set by the used range suitable row
Else
Set rngU = Union(rngU, sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol))) 'add the suitable row to the existing range
End If
End If
Next i
If Not rngT Is Nothing Then 'if rngT has been set (it contains at least a row), copy it in Sheet2
rngT.Copy Destination:=sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1) 'copy the range at once
End If
If Not rngU Is Nothing Then 'if rngU has been set (it contains at least a row), copy it in Sheet3
rngU.Copy Destination:=sh3.Range("A" & sh3.rows.count).End(xlUp).Offset(1) 'copy the range at once
End If
End Sub
Because a direct autofilter is not an option, processing the array in memory should give you the fastest result as it minimises the interaction of VBA with the excel application. I believe the following should make your code significantly faster:
Sub Copy_Data_On_Condition()
Dim dStart As Double: dStart = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim srcData As Variant
Dim sht2Data() As Variant
Dim sht2Rows As Long
Dim sht2CriteriaCol As Long: sht2CriteriaCol = 20 'T
Dim sht3Data() As Variant
Dim sht3Rows As Long
Dim sht3CriteriaCol As Long: sht3CriteriaCol = 21 'U
Dim outputCols As Long
Dim i As Long, j As Long
With Sheet1
srcData = .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
outputCols = UBound(srcData, 2)
For i = LBound(srcData) To UBound(srcData)
If srcData(i, sht2CriteriaCol) = "Yes" Then
sht2Rows = sht2Rows + 1
ReDim Preserve sht2Data(1 To outputCols, 1 To sht2Rows)
For j = 1 To outputCols
sht2Data(j, sht2Rows) = srcData(i, j)
Next j
End If
If srcData(i, sht3CriteriaCol) = "Yes" Then
sht3Rows = sht3Rows + 1
ReDim Preserve sht3Data(1 To outputCols, 1 To sht3Rows)
For j = 1 To outputCols
sht3Data(j, sht3Rows) = srcData(i, j)
Next j
End If
Next i
If sht2Rows > 0 Then
Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht2Rows, outputCols).Value = WorksheetFunction.Transpose(sht2Data)
End If
If sht3Rows > 0 Then
Sheet3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht3Rows, outputCols).Value = WorksheetFunction.Transpose(sht3Data)
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Time taken: " & Format(Timer - dStart, "0.000s")
End Sub
Another fast option is to add a dummy sheet (if possible), use autofilter then delete the dummy worksheet. This is very fast and the code is very simple:
Sub Copy_Data_On_Condition2()
Dim dStart As Double: dStart = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheet1.Copy After:=Sheet1
With ActiveSheet
With .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20, Criteria1:="Yes"
.Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20
.Rows(1).Offset(-1, 0).AutoFilter Field:=21, Criteria1:="Yes"
.Copy Destination:=Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.AutoFilter
End With
.Delete
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Timer - dStart, "0.000")
End Sub
Edit: (following comment and file share)
Your worksheet is protected but without password. Therefore, you can actually do autfilter in place without having to add a new dummy sheet. Your autfilter becomes:
Sub Copy_Data_On_Condition2()
Dim dStart As Double: dStart = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Check first if there's autfilter
If Sheet1.AutoFilterMode Then Sheet1.AutoFilter.ShowAllData
With Sheet2
If .AutoFilterMode Then .AutoFilter.ShowAllData
.Rows("4:" & .Rows.Count).ClearContents
End With
With Sheet3
If .AutoFilterMode Then .AutoFilter.ShowAllData
.Rows("4:" & .Rows.Count).ClearContents
End With
'=========== Super Symmetry Code _ Auto Filter
With Sheet1
.Unprotect
With .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20, Criteria1:="Yes"
.Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20
.Rows(1).Offset(-1, 0).AutoFilter Field:=21, Criteria1:="Yes"
.Copy Destination:=Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
.Protect
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Timer - dStart, "0.000")
End Sub
Autofilter is your best friend here if and when your data grows.
Copy Filtered Data
In this solution, it is assumed that you always want to start your resulting data in a given cell (dFirst) removing the previous contents.
Option Explicit
Sub CopyData()
Const sFirst As String = "A3"
Dim sCols As Variant: sCols = Array(20, 21)
Dim sCriteria As Variant: sCriteria = Array("Yes", "Yes")
Dim dFirst As Variant: dFirst = Array("A3", "A3")
Dim AutoFitColumns As Variant: AutoFitColumns = Array(True, True)
Dim sws As Worksheet: Set sws = Sheet1
Dim dws As Variant: dws = Array(Sheet2, Sheet3)
Dim srg As Range: Set srg = RefRange(sws.Range(sFirst))
If srg Is Nothing Then Exit Sub
Dim dData As Variant
Dim n As Long
For n = LBound(dws) To UBound(dws)
dData = GetCriteriaRows(srg, sCriteria(n), sCols(n))
If Not IsEmpty(dData) Then
WriteData dData, dws(n).Range(dFirst(n)), AutoFitColumns(n)
End If
Next n
End Sub
' Creates a reference to the range from a given first cell (range)
' to the cell at the intersection of the last non-empty row
' and the last non-empty column.
Function RefRange( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
With FirstCellRange.Cells(1)
Dim rg As Range
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count - .Column + 1)
Dim lCell As Range
Set lCell = rg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function
Dim lRow As Long: lRow = lCell.Row
Set lCell = rg.Find("*", , , , xlByColumns, xlPrevious)
Set RefRange = .Resize(lRow - .Row + 1, lCell.Column - .Column + 1)
End With
End Function
' Returns a 2D one-based array containing the rows with matching criteria
' in a given column.
Function GetCriteriaRows( _
ByVal srg As Range, _
ByVal CriteriaString As String, _
Optional ByVal CriteriaColumn As Long = 1) _
As Variant
If srg Is Nothing Then Exit Function
If Len(CriteriaString) = 0 Then Exit Function
If CriteriaColumn < 0 Then Exit Function
Dim drCount As Long: drCount = Application.CountIf(srg, CriteriaString)
If drCount = 0 Then Exit Function
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
If CriteriaColumn > cCount Then Exit Function
Dim sData As Variant
If srCount + cCount = 2 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim cValue As Variant
Dim r As Long, c As Long, n As Long
For r = 1 To srCount
cValue = CStr(sData(r, CriteriaColumn))
If cValue = CriteriaString Then
n = n + 1
For c = 1 To cCount
dData(n, c) = sData(r, c)
Next c
End If
Next r
GetCriteriaRows = dData
End Function
' Writes the values from a 2D one-based array to a range.
Sub WriteData( _
ByVal Data As Variant, _
ByVal FirstCellRange As Range, _
Optional ByVal AutoFitColumns As Boolean = False)
If FirstCellRange Is Nothing Then Exit Sub
If IsEmpty(Data) Then Exit Sub
Dim srCount As Long: srCount = UBound(Data, 1)
Dim scCount As Long: scCount = UBound(Data, 2)
Dim DoesFit As Boolean
Dim DoesNotFitExactly As Boolean
With FirstCellRange.Cells(1)
If .Worksheet.Columns.Count - .Column + 1 >= scCount Then
Select Case .Worksheet.Rows.Count - .Row + 1
Case srCount
DoesFit = True
Case Is > srCount
DoesFit = True
DoesNotFitExactly = True
End Select
End If
If DoesFit Then
Dim drg As Range: Set drg = .Resize(srCount, scCount)
drg.Value = Data
If DoesNotFitExactly Then
drg.Resize(.Worksheet.Rows.Count - .Row - srCount + 1) _
.Offset(srCount).ClearContents
End If
If AutoFitColumns Then
drg.EntireColumn.AutoFit
End If
End If
End With
End Sub
' Returns a 2D one-based array containing the values of a range
' (Not used because it is incorporated in 'GetCriteriaRows').
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim Data As Variant
If rg.Rows.Count + rg.Columns.Count = 2 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
GetRange = Data
End Function
If you don't want to consider autofilter option.
Option Explicit
Sub Copy_Data_On_Condition()
'_____________________________________________________________
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'_____________________________________________________________
Dim arr, findT As Range, findU As Range, arrStr As String, i As Long, j As Long
Dim LastRow As Long, ColT As Range, ColU As Range, k As Long, n As Long
LastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
k = 3000
For j = 2 To LastRow Step WorksheetFunction.Min(LastRow, k)
'_____________________________________________________________
'Evaluate Column T for "Yes" and create range findT
Set ColT = Sheet1.Range("T" & j + 1 & ":T" & WorksheetFunction.Min(j + k, LastRow))
arr = Evaluate("Transpose(IF((" & ColT.Address & "=" & """YES""" & ")," & _
"""A""" & "& ROW(" & ColT.Address & ") &" & _
""":U""" & "& ROW(" & ColT.Address & "),""0""))")
arrStr = Replace(Join(arr, ","), ",0", "")
If Left(arrStr, 2) = "0," Then
arrStr = Right(arrStr, Len(arrStr) - 2)
End If
For n = 15 To Len(arrStr) - Len(Replace(arrStr, ",", "", , , vbTextCompare)) Step 15
arrStr = WorksheetFunction.Substitute(arrStr, ",", "|", n)
Next n
arr = Split(arrStr, "|")
For n = 0 To UBound(arr)
If findT Is Nothing Then
'arr = Split(arrStr, "|")
Set findT = Evaluate(arr(n))
Else
Set findT = Union(Evaluate(arr(n)), findT)
End If
Next n
Debug.Print findT.Cells.Count
'_____________________________________________________________
'Evaluate Column U for "Yes" and create range findU
Set ColU = Sheet1.Range("U" & j + 1 & ":U" & WorksheetFunction.Min(j + k, LastRow))
arr = Evaluate("Transpose(IF((" & ColU.Address & "=" & """YES""" & ")," & _
"""A""" & "& ROW(" & ColU.Address & ") &" & _
""":U""" & "& ROW(" & ColU.Address & "),""0""))")
arrStr = Replace(Join(arr, ","), ",0", "")
If Left(arrStr, 2) = "0," Then
arrStr = Right(arrStr, Len(arrStr) - 2)
End If
For n = 15 To Len(arrStr) - Len(Replace(arrStr, ",", "", , , vbTextCompare)) Step 15
arrStr = WorksheetFunction.Substitute(arrStr, ",", "|")
Next n
arr = Split(arrStr, "|")
For n = 0 To UBound(arr)
If findU Is Nothing Then
'arr = Split(arrStr, "|")
Set findU = Evaluate(arr(n))
Else
Set findU = Union(Evaluate(arr(n)), findU)
End If
Next n
Debug.Print findU.Cells.Count
'_____________________________________________________________
Next j
findT.Copy Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Offset(1)
findU.Copy Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1)
'_____________________________________________________________
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"
End Sub

Insert Row when 2 conditions are met

I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub

To Calculate Average Value of Multiple Range

I'm trying to calculate the Average value of multiple ranges as shown in attached Fig.
Conditions -
It should match the cell value of column "L" and "M" with a range of column "A" and Make a range (e.g 322810 to 324900) to calculate the average of column B values which are against the specific range (e.g 322810 to 324900).
I've been able to write the following code but it obviously not working.
Dim lastrow As Long
Dim i As Long, j As Long
With Worksheets("Source")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lastrow + 1 'loop whole range (column C)
If .Cells(i, "L") = .Range("A").Value Then 'If column L cell value match with any cell of Range "A"
For j = i To lastrow 'Loop "group" range.
If .Cells(j, "M") = .Range("A").Value Then ' (end of small group range) then apply formula
.Cells(i, "N").Formula = "=AVERAGE(B" & i & ":B" & j & ")" 'AVG
Exit For
End If
Next j
End If
Next I
End With
All kind of help will be appreciated (Formula or VBA Code)
Yes, BigBen is right. This is the way. The Formula in my example is
=AVERAGEIFS($B$3:$B$16,$A$3:$A$16,">="&L4,$A$3:$A$16,"<="&M4)
Try,
Sub test()
Dim Lastrow As Long
Dim i As Long, j As Long
Dim r As Long
Dim mPoint As Long
Dim Ws As Worksheet
Dim vDB, vR()
Dim rngStart As Range, rngEnd As Range
Dim rngDB As Range
Set Ws = Worksheets("Source")
With Ws
Lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
vDB = .Range("L3", .Range("m" & .Rows.Count).End(xlUp))
r = UBound(vDB, 1)
ReDim vR(1 To r, 1 To 1)
For i = 1 To r
For k = 1 To Lastrow
If .Range("a1").Cells(k) = vDB(i, 1) Then
Set rngStart = .Range("a1").Cells(k)
mPoint = rngStart.Row
Exit For
End If
Next k
If rngStart Is Nothing Then
Else
For k = mPoint To Lastrow
If .Range("a1").Cells(k) = vDB(i, 2) Then
Set rngEnd = .Range("a1").Cells(k)
Exit For
End If
Next k
End If
If rngStart Is Nothing Or rngEnd Is Nothing Then
Else
Set rngDB = .Range(rngStart, rngEnd).Offset(, 1)
Debug.Print rngDB.Address
vR(i, 1) = WorksheetFunction.Average(rngDB)
End If
Set rngStart = Nothing
Set rngEnd = Nothing
Next i
.Range("n3").Resize(r) = vR
End With
End Sub

How to apply multiple criteria to .Find?

I adapted code I found online.
It finds the string "car" in column A and returns the rows as an array
It assigns a variable to the length of the array (how many matches it found)
It assigns a variable to generate a random number between 0 and the length of the array
It then prints a random matching row's value into K3
Dim myArray() As Variant
Dim x As Long, y As Long
Dim msg As String
With ActiveSheet.Range("A1:A" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
ReDim Preserve myArray(y)
myArray(y) = c.Row
y = y + 1
Set c = .findNext(c)
If c Is Nothing Then
GoTo DoneFinding
End If
Loop While c.Address <> firstAddress
End If
DoneFinding:
End With
For x = LBound(myArray) To UBound(myArray)
msg = msg & myArray(x) & " "
Next x
ArrayLen = UBound(myArray) - LBound(myArray)
random_index = WorksheetFunction.RandBetween(0, ArrayLen)
MsgBox myArray(random_index)
Dim test As String
test = "B" & myArray(random_index)
Range("K3").Value = Range(test)
Example
I'm struggling with adapting the find code to allow for multiple criteria. So in my example, it finds "Car". What if I want to find matches that had "Car" in column A and "Red" in column D?
I tried
With ActiveSheet.Range("A1:A" & "D1:D" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row & ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row)
Set c = .find("Car", "Red", LookIn:=xlValues)
I get type mismatch on the Set line.
In case it is confusing, it currently looks for a string e.g. "Car" but I will eventually link this to the variable which will be assigned to a data validation list. So if the user chooses "car" from a drop down list, this is what it will search for.
Maybe Advancde Filter is something that fit your needs:
Example Code
Option Explicit
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub
Edit according comment:
You can use the advanced filter and then loop through the filter results:
Option Explicit
Public CurrentRow As Long
Public Sub FilterData()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim CriteriaRange As Range
Set CriteriaRange = ws.Range("A1", "E2")
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
DataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=CriteriaRange, Unique:=False
End Sub
Public Sub ShowAll()
On Error Resume Next
ActiveSheet.ShowAllData
CurrentRow = 1
On Error GoTo 0
End Sub
Public Sub GetNextResult()
FilterData
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("YourSheetName")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim DataRange As Range
Set DataRange = ws.Range("A4", "E" & LastRow)
Dim FilteredData As Range
Set FilteredData = DataRange.Resize(ColumnSize:=1).SpecialCells(xlCellTypeVisible)
If CurrentRow + 1 > FilteredData.Cells.Count Then
CurrentRow = 1
End If
CurrentRow = CurrentRow + 1
Dim i As Long
Dim Cell As Variant
For Each Cell In FilteredData
i = i + 1
If i = CurrentRow Then
Cell.EntireRow.Select
'or
'MsgBox Cell.Value & vbCrLf & Cell.Offset(0, 1) & vbCrLf & Cell.Offset(0, 2) & vbCrLf & Cell.Offset(0, 3) & vbCrLf & Cell.Offset(0, 4)
End If
Next Cell
End Sub

Resources