Don't know much about Excel vba. How can I return the location of the cell in the range that is the maximum value (e.g., "MaxVal")?
Sub FillSched()
Dim LTrig As Long
Dim i As Integer
Dim MaxVal As Double
Dim WorkRange As Range
Worksheets("Inputs").Activate
LTrig = Range("Trigger").Value
Worksheets("Daily").Activate
For i = 0 To 5
If Range("AggInvStart").Offset(i, 0).Value > LTrig Then
Set WorkRange = Range("M" & i + 5 & ":" & "O" & i + 5)
MaxVal = WorksheetFunction.Max(WorkRange)
End If
Next i
End Sub
Thank you in advance.
In your code MaxValue is just a calculated value not a range.
You would need to get the position of the WorkRange that contains that MaxValue
Sub FillSched()
Dim LTrig As Long
Dim i As Integer
Dim MaxVal As Double
Dim WorkRange As Range
Dim col Long
Dim rw As Long
Worksheets("Inputs").Activate
LTrig = Range("Trigger").Value
Worksheets("Daily").Activate
For i = 0 To 5
If Range("AggInvStart").Offset(i, 0).Value > LTrig Then
Set WorkRange = Range("M" & i + 5 & ":" & "O" & i + 5)
MaxVal = WorksheetFunction.Max(WorkRange)
rw = WorkRange.Row
col = WorkRange.Column
End If
Next i
MsgBox "MaxValue is in Row: " & rw & ", Column: " & col
End Sub
Sub FillSched()
Dim rngSearch As Range, WorkRange As Range
Dim MaxVal as Double, lCol as Long, lRow as Long, sAddress as String
With WorksheetFunction
Set rngSearch = Range("AggInvStart").Resize(6, 1) ' Define search range
MaxVal = .Max(rngSearch.Value2) ' Get its max value
If MaxVal <= Range("Trigger").Value2 Then _ ' Use this if you do not want to
Exit Sub ' find MaxVal when is <= Range("Trigger")
lCol = Range("AggInvStart")(1,1).Column ' Get first column
lRow = Range("AggInvStart")(1,1).Row - 1 ' Get one row before first
Set WorkRange = Cells(lRow + .Match(MaxVal, rngSearch, 0), lCol) ' Get its location
sAddress = WorkRange.Address ' Get Cell Address
lRow = WorkRange.Row ' Get Row No
lCol = WorkRange.Column ' Get Column No
End With
End Sub
I hope this helps!
PS: I think that in your original code, you want LTrig to be Double. Also, it has to be initialized to a very small number (the code as it stands will fail if the max value is negative because the Dim statement initializes LTrig to zero.)
Related
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
My end goal is to replace about 200,000 =Offset formulas in an Excel sheet with the appropriate direct cell reference with VBA. For example, I have =Offset(Sheet1!A1,Sheet2!B3,Sheet2!G5). B3 in sheet2 contains the number 2 and G5 in sheet2 contains the number 3. The offset formula pulls the number in sheet1 that is 2 rows and 3 columns (C3) away from A1. There are 200,000 of these formulas in the sheet and I would like to use VBA to change every one to =Sheet1!C3 in the example above. Clearly every direct cell reference is different - they're not all C3.
I have the following code right now but it replaces with a hardcoded cell number, which I would like to change to be dynamic.
My code is below:
Sub FindReplaceAll()
Dim sht As Worksheet
Dim cell As Range
Dim fnd As Variant
Dim rplc As Variant
fnd = "Offset*"
rplc = "Sheet1!C3"
For Each sht In ActiveWorkbook.Worksheets
sht.Cells.Replace what:=fnd, Replacement:=rplc, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next sht
End Sub
The solution is tried only with simplest OFFSET formula. For coverting more complex offset formula more tweaking may be needed.
Option Explicit
Sub test()
Dim Xformula As String, Yformula As String
Dim Xref As String, XRow As String, XCol As String
Dim YRow As Long, YCol As Long
Dim ZRow As Long, ZCol As Long
Dim Zsht As String, ZColStr As String
Dim Ws As Worksheet, Cel As Range
Dim tm As Double, Cnt As Long
tm = Timer
Set Ws = ThisWorkbook.ActiveSheet
Cnt = 0
For Each Cel In Ws.UsedRange.Cells
If Mid(Cel.Formula, 2, 6) = "OFFSET" Then
On Error Resume Next
Xformula = Cel.Formula
Xformula = Replace(Xformula, "=OFFSET(", "")
Xformula = Left(Xformula, Len(Xformula) - 1)
Xref = Split(Xformula, ",")(0)
'Debug.Print Xref, Xformula, Cel.Address
XRow = Split(Xformula, ",")(1)
XCol = Split(Xformula, ",")(2)
YRow = Evaluate(XRow)
YCol = Evaluate(XCol)
If InStr(1, Xref, "!") > 0 Then
Zsht = Split(Xref, "!")(0) & "!"
Else
Zsht = ""
End If
ZRow = Range(Xref).Row + YRow
ZCol = Range(Xref).Column + YCol
ZColStr = Split(Cells(1, ZCol).Address, "$")(1)
Zsht = "=" & Zsht & ZColStr & ZRow
'The cells contain #REF or could not be converted would me marked Red
If Err <> 0 Then
Cel.Interior.Color = vbRed
Err.Clear
On Error GoTo 0
Else
Cel.Formula = Zsht
Cnt = Cnt + 1
End If
End If
Next
Debug.Print Timer - tm & " Seconds taken to convert " & Cnt & " formulas "
End Sub
Since code is tested with around 1000 offset formula only takes 3 sec. For working with 200 K formula it may be needed to add standard techniques like
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False
But since i don't personally prefer it, Another option is to tweak the code to work on selected range only and select a limited range in the sheet at a time and execute.
May try on trial workbook / Worksheet only and feedback.
Edit: Adding Array based solution for faster performance, It could be made somehow more faster by using For Each XVariant in Arr and by eliminating Union(ErrRng,... only if there is no need to mark error cells. It takes around 90 sec (70 sec to calculate and 20 more seconds to replace) to change 300 K Offset formula.
Option Explicit
Sub test()
Dim Xformula As String, Yformula As String
Dim Xref As String, XRow As String, XCol As String
Dim YRow As Long, YCol As Long
Dim ZRow As Long, ZCol As Long
Dim Zsht As String, ZColStr As String
Dim Ws As Worksheet, ErrRng As Range, Xcel As Variant
Dim tm As Double, Cnt As Long, Arr As Variant
Dim Rw As Long, Col As Long, RngRowOffset As Long, RngColOffset As Long
tm = Timer
Set Ws = ThisWorkbook.ActiveSheet
Cnt = 0
Arr = Ws.UsedRange.Formula
RngRowOffset = Ws.UsedRange(1, 1).Row - 1
RngColOffset = Ws.UsedRange(1, 1).Column - 1
'Debug.Print RngRowOffset, RngColOffset
For Rw = 1 To UBound(Arr, 1)
For Col = 1 To UBound(Arr, 2)
Xcel = Arr(Rw, Col)
If Mid(Xcel, 2, 6) = "OFFSET" Then
On Error Resume Next
Xformula = Xcel
Xformula = Replace(Xformula, "=OFFSET(", "")
Xformula = Left(Xformula, Len(Xformula) - 1)
Xref = Split(Xformula, ",")(0)
'Debug.Print Xref, Xformula, Cel.Address
XRow = Split(Xformula, ",")(1)
XCol = Split(Xformula, ",")(2)
YRow = Evaluate(XRow)
YCol = Evaluate(XCol)
If InStr(1, Xref, "!") > 0 Then
Zsht = Split(Xref, "!")(0) & "!"
Else
Zsht = ""
End If
ZRow = Range(Xref).Row + YRow
ZCol = Range(Xref).Column + YCol
ZColStr = Split(Cells(1, ZCol).Address, "$")(1)
Zsht = "=" & Zsht & ZColStr & ZRow
'The cells containg #REF or could not be converted would me marked Red
If Err <> 0 Then
If ErrRng Is Nothing Then
Set ErrRng = Cells(Rw + RngRowOffset, Col + RngColOffset)
Else
Set ErrRng = Union(ErrRng, Cells(Rw + RngRowOffset, Col + RngColOffset))
End If
Err.Clear
On Error GoTo 0
Else
Arr(Rw, Col) = Zsht
Cnt = Cnt + 1
End If
End If
Next
Next
Debug.Print Timer - tm & " Seconds taken to Calculate " & Cnt & " formulas "
Ws.UsedRange.Formula = Arr
Debug.Print Timer - tm & " Seconds taken to Repalce formulas "
ErrRng.Interior.Color = vbRed
Debug.Print Timer - tm & " Seconds taken to mark error cells "
End Sub
I am trying to get unique values from dynamic F column and store it in an array. I am getting "Object Required error for my code while setting Selection variable to a dynamic range. Please help.
Sub UniqueFilter()
Dim tmp As String
Dim arr() As String
Dim Selection As Range
Dim lrow As Long
Dim str As String
Dim cell As Range
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("14Feb19")
sht.Activate
'Set Selection = sht.Range(sht.Cells(1, 6), sht.Cells(Rows.Count, 6).End (xlUp)).Select
lrow = shData.Range("F" & Rows.Count).End(xlUp).Row
Set Selection = sht.Range("F2:F" & lrow).Select
If Not Selection Is Nothing Then
For Each cell In Selection
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
End Sub
You can achieve your goal without having to use Selection at all.
Just copy the range content and transpose it into an array:
Sub UniqueFilter()
Dim arr() As String
Dim tmp As Variant
Dim lrow As Long
Dim sht As Worksheet
Dim index As Integer
Dim count As Integer
Set sht = ThisWorkbook.Worksheets("14Feb19")
sht.Activate
lrow = sht.Range("F" & Rows.count).End(xlUp).Row
'Copying and trasposing selected Range
tmp = Application.Transpose(sht.Range("F2:F" & lrow).Value)
'Cleaning from temp array all empty values
count = 1
For index = 1 To UBound(tmp, 1) - LBound(tmp, 1) + 1
ReDim Preserve arr(1 To count)
If tmp(index) <> "" Then
arr(count) = tmp(index)
count = count + 1
End If
Next
End Sub
(special thanks to #Nathan_Sav, who helped simplifying the code)
Please refer to the attached picture to have a better idea.
I have multiple rows in my worksheet with a group name and a lot of values. Each group shows multiple times in my table. Now I would like to sum values for every group and return them. What is the most efficient way to do this?
Now I have the code to store each row's total value to an array and sum it up like below:
Dim arr() as variant
Dim n as integer
Dim sum as variant
For n = firstrow to lastrow 'assume firstrow and lastrow are known numbers
arr = Range(Cells(n, 3),Cells(n,column.count)).Value
sum = Workbookfunction.sum(arr)
Next n
Any thoughts will be quite helpful!
Use SUMPRODUCT:
=SUMPRODUCT(($A$7:$A$18=A1)*($B$7:$G$18))
A VBA Array Version
Before using this code adjust the data in the customize section to fit your needs.
The commented blocks starting with ' str1 = " are used for debugging. You can delete them or uncomment them to see some 'subtotals' in the immediate window.
Option Explicit
Sub SumGroups()
'-- Customize BEGIN --------------------
Const cStrG As String = "B2" 'First cell of the group section
Const cStrD As String = "B15" 'First cell of the data section
'-- Customize END ----------------------
Dim oRng As Range
Dim oRngResults As Range
Dim arrNames As Variant
Dim arrData As Variant
Dim arrResults As Variant
Dim loNames As Long
Dim loData As Long
Dim iDataCol As Integer
Dim dblResults As Double
'Debug
Dim lo1 As Long
Dim i1 As Integer
Dim str1 As String
Dim str2 As String
Dim dTime As Double
' 'Determine the group names range using the first cell of the data section.
' Set oRng = Range(cStrG).Resize(Range(cStrD).Rows.End(xlUp).Row - 1, 1)
'Determine the group names range using the last cell of the group section.
Set oRng = Range(cStrG).Resize(Range(cStrG).Rows.End(xlDown).Row - 1, 1)
'Determine the range of the results
Set oRngResults = oRng.Offset(0, 1)
'Paste the group names range into an array
arrNames = oRng
' str1 = "arrNames:"
' For lo1 = LBound(arrNames) To UBound(arrNames)
' str1 = str1 & vbCrLf & lo1 & ". " & Chr(9) & arrNames(lo1, 1)
' Next
' Debug.Print str1
'Determine the data range using resize NOT finished.
' Set oRng = Range(cStrD).Resize(Cells(Cells.Rows.Count, _
Range(cStrD).Column).End(xlUp).Row - Range(cStrD).Row + 1, 1)
'Determine the data range not using resize.
Set oRng = Range(Cells(Range(cStrD).Row, Range(cStrD).Column), _
Cells(Cells(Cells.Rows.Count, Range(cStrD).Column).End(xlUp).Row, _
Cells(Range(cStrD).Row, Cells.Columns.Count).End(xlToLeft).Column))
'Paste the data range into an array
arrData = oRng
Set oRng = Nothing 'Release object variable
' str1 = "arrData:"
' For lo1 = LBound(arrData) To UBound(arrData)
' str2 = ""
' For i1 = LBound(arrData, 2) To UBound(arrData, 2)
' str2 = str2 & Chr(9) & arrData(lo1, i1)
' Next
' str1 = str1 & vbCrLf & lo1 & "." & str2
' Next
' Debug.Print str1
arrResults = oRngResults
For loNames = LBound(arrNames) To UBound(arrNames)
dblResults = 0
For loData = LBound(arrData) To UBound(arrData)
If arrNames(loNames, 1) = arrData(loData, 1) Then
For iDataCol = LBound(arrData, 2) + 1 To UBound(arrData, 2)
dblResults = dblResults + arrData(loData, iDataCol)
Next
End If
Next
arrResults(loNames, 1) = dblResults
Next
' str1 = "arrResults:"
' For lo1 = LBound(arrResults) To UBound(arrResults)
' str1 = str1 & vbCrLf & lo1 & ". " & Chr(9) & arrResults(lo1, 1)
' Next
' Debug.Print str1
oRngResults = arrResults
Set oRngResults = Nothing 'Release object variable
End Sub
At 50000 rows it calculates in less than a second. The determination of the ranges gave me quite some grief, but I still think they could probably be improved. Would appreciate some feedback regarding the ranges.
I've rewritten the code to use instead of yours. It adds up all the rows between two row indexes, as long as the first cell in each row has a value of "Group A".
Dim firstRow As Integer
Dim lastRow As Integer
Dim currentSum As Integer
Dim currentGroup As String
'Change firstRow and lastRow to the row indexes of the cells you're adding
firstRow = 10
lastRow = 13
currentSum = 0
currentGroup = "Group A"
For n = firstRow To lastRow
If Cells(n, 1).Value = currentGroup Then
currentSum = currentSum + Application.sum(Range(Cells(n, 1), Cells(n, 50)))
End If
'Put the cell name of where you want the value, instead of B3
Range("B3").Value = currentSum
'Change currentGroup to the next group here
Next n
Select the rows (A:J) if column E contains more than 4 Cells with value. Next is to selective print the selected Rows. Then it need to repeat the process until the last filled cell. Have been searching for a macro to get tenter link description herehis done for weeks but sadly to no avail.
Hope you all can assist me on this.
After being select as such i believe i could just proceed with printing under "printing selection" setting
This is one of the printed result of the 2 selected row
Added code from comments
Sub EnquiryPrep()
Dim x As Integer
Dim rng As Range
With ActiveSheet
LR = .Range("a" & Rows.Count).End(xlUp).Row
For Each cell In .Range("e7:e" & LR)
If cell.Value <> "" Then
If rng Is Nothing Then
Set rng = cell.Offset(, -4).Resize(, 10)
Else
Set rng = Union(rng, cell.Offset(, -4).Resize(, 10))
End If
End If
Next cell
rng.Select
End With
End Sub
Put this into your ThisWorkbook Code
WHAT IS OUTPUT FROM DEBUG.PRINT statments?? Cut/Paste from Immediate
window below code
Try:
Sub PrintValidRows()
Const SHEET_NUM As Integer = 1 ' Which Sheet to Use
Const CHECK_COL As Integer = 5 ' Column E
Const START_ROW As Integer = 8
Const MIN_FILLED As Integer = 5 ' Min number required for print
Const LAST_COL As String = "H" ' Last column to print
Dim lastCellBlank As Boolean
Dim lngRow As Long
Dim lngLastRow As Long
Dim lngStartRow As Long
Dim intNumFilled As Integer
Dim strRange As String
Dim strPrintRange As String
Dim ws As Worksheet
Set ws = Sheets(SHEET_NUM)
ws.Activate
ws.Cells(1, 1).Select
intNumFilled = 0
' Get last row of data
lngLastRow = ActiveCell.SpecialCells(xlLastCell).Row
Debug.Print "Last Row: "; lngLastRow
lngStartRow = START_ROW
For lngRow = START_ROW To lngLastRow
If IsEmpty(Cells(lngRow, CHECK_COL)) Then
If intNumFilled >= MIN_FILLED Then
strRange = "A" & lngStartRow & ":" & LAST_COL & lngRow - 1
Debug.Print "Adding Range: " & strRange
If lngStartRow = START_ROW Then ' first range
strPrintRange = strRange
Else
strPrintRange = strPrintRange & "," & strRange
End If
End If
' Reset Filled Cell Counter
intNumFilled = 0
' Reset StartRow to next row
lngStartRow = lngRow + 1
Else
intNumFilled = intNumFilled + 1
End If
Next lngRow
' Check for last set of data
If intNumFilled >= MIN_FILLED Then
strRange = "A" & lngStartRow & ":" & LAST_COL & lngRow - 1
Debug.Print "Adding Range: " & strRange
If lngStartRow = START_ROW Then ' first range
strPrintRange = strRange
Else
strPrintRange = strPrintRange & "," & strRange
End If
End If
' Show Print Range in Immediate Window
Debug.Print "Print Range: " & strPrintRange
If strPrintRange <> "" Then
Range(strPrintRange).Select
End If
' You can record a macro to get it to printout exactly what how want
' REMOVE THIS TO TEST HIGHLIGHTING
'Application.Selection.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
End Sub