VBA - Returning Max value using array VBA

[Mark_Annonyous]

Hi Peeps,

Like most people, i just use the same code over and over again, tweaking it as necessary, but I've hit a block when going from sum to Max.
It seems to be pulling the max value of Zero, and the first in the list that meets the criteria.

Any ideas?

Hope everyone is well!

Sub STRUCAV()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim DataImportCounter, RowCounter, ColumnCounter, LastRowDataImport, LastRow As Integer
Dim VName As String
Dim AvailDate As Date

LastRowDataImport = FindLastRow("Inputs")
With Worksheets("Inputs")
 Reutdata = Range(.Cells(1, 1), .Cells(LastRowDataImport, 570))
 End With

LastRowSummary = FindLastRow2("Sheet2")
With Worksheets("Sheet2")
 alldata = Range(.Cells(1, 1), .Cells(LastRowSummary, 570))
 output1 = Range(.Cells(12, 6), .Cells(LastRowSummary, 570))
 
For ColumnCounter = 6 To 570
     Exportdate = alldata(1, ColumnCounter)
     For RowCounter = 12 To LastRowSummary
     Maxfix = 0
                     
     VName = alldata(RowCounter, 1) 'For each cell being evaluated, we need to store the Export country in column 1 to be evaluated.
         For DataImportCounter = 1 To LastRowDataImport
         
            If Reutdata(DataImportCounter, 3) = VName Then
                            If Exportdate >= Reutdata(DataImportCounter, 45) And Exportdate <= Reutdata(DataImportCounter, 46) Then
                            Maxfix = WorksheetFunction.Max(Reutdata(DataImportCounter, 48))

                            End If
                 
            End If
            
            Next DataImportCounter

            output1(RowCounter - 11, ColumnCounter - 5) = Maxfix


    Next RowCounter
Next ColumnCounter

Range(.Cells(12, 6), .Cells(LastRowSummary, 570)) = output1


End With
Application.ScreenUpdating = True



End Sub





Function FindLastRow(ShtName) As Integer

For X = 1 To 25000
    If Sheets(ShtName).Cells(X, 1) = "" Then
        Exit For
    End If
Next X

FindLastRow = X - 1

End Function

Function FindLastRow2(ShtName) As Integer


For X = 12 To 2000
    If Sheets(ShtName).Cells(X, 1).Value = "" Then
        Exit For
    End If
Next X

FindLastRow2 = X - 1

End Function

 

[rlv01]

Try this instead

Maxfix = WorksheetFunction.Max(Reutdata)

 

[Mark_Annonyous]

Try this instead

Maxfix = WorksheetFunction.Max(Reutdata)

Hey, thanks for your help, but how would it be picking up column 48? Or am i missing something?

 

[rlv01]

Your description was hard to understand so I made a guess that you wanted the max range value. If you just want the max range in col 48, then create an array that just includes col 48.

Dim ColData
ColData = Range(.Cells(1, 48), .Cells(LastRowDataImport, 48))
Maxfix = WorksheetFunction.Max(ColData)

(Tip: For future posts , you should try to use code tags like I did above when posting your code. It makes it easier to read.)

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

 

[Mark_Annonyous]

Thankyou so much mate. Ill have a whiz tomorrow when i get in the office.

Really appreciate your help.

Mark

 

[Mark_Annonyous]

Your description was hard to understand so I made a guess that you wanted the max range value. If you just want the max range in col 48, then create an array that just includes col 48.

Dim ColData
ColData = Range(.Cells(1, 48), .Cells(LastRowDataImport, 48))
Maxfix = WorksheetFunction.Max(ColData)

(Tip: For future posts , you should try to use code tags like I did above when posting your code. It makes it easier to read.)

How to Post Your VBA Code

Post your VBA code.

www.mrexcel.com

Hi mate,

Thanks a ton for your help, I tried the method, but its only populating the sheet with one value, to the exclusion of all others. I am looking to pull the largest value meeting the conditions set out below. Any clues? Would it help if i posted a sample sheet?

Again, thanks for your help.

ub STRUCAV()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim DataImportCounter, RowCounter, ColumnCounter, LastRowDataImport, LastRow As Integer
Dim VesselName As String
Dim AvailDate As Date

LastRowDataImport = FindLastRow("Inputs")
With Worksheets("Inputs")
 Reutdata = Range(.Cells(1, 1), .Cells(LastRowDataImport, 570))
 End With

LastRowSummary = FindLastRow2("Sheet2")
With Worksheets("Sheet2")
 alldata = Range(.Cells(1, 1), .Cells(LastRowSummary, 570))
 output1 = Range(.Cells(12, 6), .Cells(LastRowSummary, 570))
 
Dim ColData
ColData = Range(.Cells(1, 48), .Cells(LastRowDataImport, 48))
     Exportdate = alldata(1, ColumnCounter)


For ColumnCounter = 6 To 570

     For RowCounter = 12 To LastRowSummary
     Maxfix = 0
                      
     VesselName = alldata(RowCounter, 1) 'For each cell being evaluated, we need to store the Export country in column 1 to be evaluated.
         For DataImportCounter = 1 To LastRowDataImport
          
            If Reutdata(DataImportCounter, 3) = VesselName Then
                            If Exportdate >= Reutdata(DataImportCounter, 45) And Exportdate <= Reutdata(DataImportCounter, 46) Then
                            Maxfix = WorksheetFunction.Max(ColData)
                            

                            End If
                  
            End If
             
            Next DataImportCounter

            output1(RowCounter - 11, ColumnCounter - 5) = Maxfix


    Next RowCounter
Next ColumnCounter

Range(.Cells(12, 6), .Cells(LastRowSummary, 570)) = output1


End With
Application.ScreenUpdating = True



End Sub





Function FindLastRow(ShtName) As Integer

For X = 1 To 25000
    If Sheets(ShtName).Cells(X, 1) = "" Then
        Exit For
    End If
Next X

FindLastRow = X - 1

End Function

Function FindLastRow2(ShtName) As Integer


For X = 12 To 2000
    If Sheets(ShtName).Cells(X, 1).Value = "" Then
        Exit For
    End If
Next X

FindLastRow2 = X - 1

End Function

 

[rlv01]

I am looking to pull the largest value meeting the conditions set out below.

I don't think I am following. My first example showed you how to pull the largest value in a range of cells beginning with cell(1,1) and ending at cell (LastRowDataImport, 570)). My second example showed you how to pull the largest value in a range of cells in column 48, beginning with row 1 and ending at row LastRowDataImport. So at this point I have no idea what you want to do and my interest is waning. I can tell you that your original statementMaxfix = WorksheetFunction.Max(Reutdata(DataImportCounter, 48)) will never work because you are only feeding the max function a single array point. What I mean by that can be made more clear by re-writing the above as two statements:

Dim X 
X = Reutdata(DataImportCounter, 48)
Maxfix = WorksheetFunction.Max(X)

In the above case, the max of X is always going to be X.

 

[Mark_Annonyous]

I don't think I am following. My first example showed you how to pull the largest value in a range of cells beginning with cell(1,1) and ending at cell (LastRowDataImport, 570)). My second example showed you how to pull the largest value in a range of cells in column 48, beginning with row 1 and ending at row LastRowDataImport. So at this point I have no idea what you want to do and my interest is waning. I can tell you that your original statementMaxfix = WorksheetFunction.Max(Reutdata(DataImportCounter, 48)) will never work because you are only feeding the max function a single array point. What I mean by that can be made more clear by re-writing the above as two statements:

Dim X
X = Reutdata(DataImportCounter, 48)
Maxfix = WorksheetFunction.Max(X)

In the above case, the max of X is always going to be

Sorry, I am clearly not winning in my quest to avoid **** people off.
Below is the code I have in the workbook, and i have also included two images.

The cover page (sheet 2) includes the names, Column 1, and the dates, row 1, and the table being created is from Cells(12,6) to (Last row, 570).

I am seeking to return the highest score on that date, for each user using data found on inputs, .

Scores for each user are found in Inputs Range(2,3) to (last Row, 3), Dates in columns 45 and 46. Corresponding score in 48

Again, I am re-using code that ive used for thousands of other applications, as i am no where near the level of freehand.

Sub STRUCAV()

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim DataImportCounter, RowCounter, ColumnCounter, LastRowDataImport, LastRow As Integer
Dim VesselName As String
Dim AvailDate As Date

LastRowDataImport = FindLastRow("Inputs")
With Worksheets("Inputs")
 Reutdata = Range(.Cells(1, 1), .Cells(LastRowDataImport, 570))
 End With

LastRowSummary = FindLastRow2("Sheet2")
With Worksheets("Sheet2")
 alldata = Range(.Cells(1, 1), .Cells(LastRowSummary, 570))
 output1 = Range(.Cells(12, 6), .Cells(LastRowSummary, 570))
 
Dim X
X = Reutdata(DataImportCounter, 48)

     
Exportdate = alldata(1, ColumnCounter)


For ColumnCounter = 6 To 570

     For RowCounter = 12 To LastRowSummary
     
                      
     VesselName = alldata(RowCounter, 1)
         For DataImportCounter = 1 To LastRowDataImport
          
            If Reutdata(DataImportCounter, 3) = VesselName Then
                            If Exportdate >= Reutdata(DataImportCounter, 45) And Exportdate <= Reutdata(DataImportCounter, 46) Then
                            Maxfix = Maxfix = WorksheetFunction.Max(X)
                            
                            End If
            End If
             
            Next DataImportCounter

            output1(RowCounter - 11, ColumnCounter - 5) = Maxfix


    Next RowCounter
Next ColumnCounter

Range(.Cells(12, 6), .Cells(LastRowSummary, 570)) = output1


End With
Application.ScreenUpdating = True



End Sub





Function FindLastRow(ShtName) As Integer

For X = 1 To 25000
    If Sheets(ShtName).Cells(X, 1) = "" Then
        Exit For
    End If
Next X

FindLastRow = X - 1

End Function

Function FindLastRow2(ShtName) As Integer


For X = 12 To 2000
    If Sheets(ShtName).Cells(X, 1).Value = "" Then
        Exit For
    End If
Next X

FindLastRow2 = X - 1

End Function

 

[rlv01]

If you post a graphic image of your data, the number of people willing to manually type in your data to experiment to help you will be limited. Consider using this free tool instead to post some sample data.

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

Example.

tmpz.xlsm
	A	B	C	D
1	Name	Start	End	Max Score
2	Wales	4/28/2023	5/8/2023	10
3	Woeness	5/28/2023	7/7/2023	40
4	Rochelle	6/27/2023	7/9/2023	50
5	Screar	7/27/2023	1/1/2024	90
6	Jargonels	8/26/2023	9/7/2023	90
7	Clownade	9/25/2023	10/7/2023	0
8	Tess	10/25/2023	11/6/2023	120
9	Laicizes	11/24/2023	12/6/2023	0
10	Tomboys	4/28/2023	1/1/2024	140
Inputs

tmpz.xlsm
	A	B	C	D	E	F	G
1	Name	5/5/2023	6/5/2023	7/5/2023	8/5/2023	9/5/2023	11/5/2023
2	Wales	10	20	30	40	50	60
3	Woeness	20	30	40	50	60	70
4	Rochelle	30	40	50	60	70	80
5	Screar	40	50	60	70	80	90
6	Jargonels	50	60	70	80	90	100
7	Clownade	60	70	80	90	100	110
8	Tess	70	80	90	100	110	120
9	Laicizes	80	90	100	110	120	130
10	Tomboys	90	100	110	120	130	140
Scores

Sub MaxScore()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim SD As Object
    Dim EndD As Date, ScoreD As Date, StartD As Date
    Dim I As Long, J As Long, LastRow As Long, MaxScore As Long, Ofs As Long
    Dim R As Range, R2 As Range, Rng As Range, rngColData As Range, rngColData2 As Range, rngRowData As Range
    Dim KeyStr As Variant, RefStr As Variant, SA As Variant

    Set SD = CreateObject("Scripting.dictionary")
    Set WB = ThisWorkbook

    Set WS = WB.Worksheets("Scores")
    With WS
        Set rngColData = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))    'range to last cell in column w/data
        Set rngRowData = .Range("B1", .Cells(1, .Columns.Count).End(xlToLeft))    'range of data in row
    End With

    Set WS = WB.Worksheets("Inputs")
    With WS
        Set rngColData2 = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))    'range to last cell in column w/data
    End With

    'Determine score date range for each player
    For Each R In rngColData2
        KeyStr = R.Value
        StartD = R.Offset(0, 1).Value
        EndD = R.Offset(0, 2).Value
        I = -1
        J = 0
        Ofs = 0
        For Each R2 In rngRowData
            ScoreD = R2.Value
            If ScoreD >= StartD And I = -1 Then
                I = Ofs
            End If
            Ofs = Ofs + 1
            If ScoreD >= StartD And ScoreD <= EndD Then
                J = J + 1
            End If
        Next R2

        If I = -1 Or J = 0 Then
            RefStr = "0:0"
        Else
            RefStr = I & ":" & J
        End If
        SD.Add KeyStr, RefStr
    Next R

    'Determine max score for date range for each player
    For Each R In rngColData
        KeyStr = R.Value
        If SD.exists(KeyStr) Then
            RefStr = SD.Item(KeyStr)
            If RefStr = "0:0" Then
                RefStr = 0
            Else
                SA = Split(RefStr, ":")
                Set Rng = R.Offset(0, SA(0) + 1).Resize(1, SA(1))
                MaxScore = WorksheetFunction.Max(Rng)
                RefStr = MaxScore
            End If
            SD.Item(KeyStr) = RefStr
        End If
    Next R

    'Write max score for each player to sheet 'Input'.
    For Each R In rngColData2
        KeyStr = R.Value
        If SD.exists(KeyStr) Then
            R.Offset(0, 3).Value = Val(SD.Item(KeyStr))
        End If
    Next R
End Sub