Load part of data to memory, perform some calculations and rank then show alert with message box -vba

[kelly mort]

This is the formula I am using to get data to second sheet.

Sheet2.Range("D7:M" & lr) = "=Sheet1!I7+Sheet1!S7*0.2"

Sheet1

Sheet2

Now what I want to do is to be able to load the portion of data from sheet2 for say category "X" into memory. Now I don't want to interact with the worksheet anymore. So looking at the formula as a guide, I want to perform those calculations in memory. Then I find the totals each row , D:M into N .

All in memory, if only that's possible.

If all the above go well, then what I want next is to be able to rank the total for ID 408 against the items in column N Sheet2 then display outcome with message box.

I wish and hope some can pull it up for me.

Thanks

 

[DanteAmor]

This is it:

The code does not match with the image data on sheet1.
Are you sure that this is the last code and that the image is the data you work with?

a = Sheet1.Range("B7:AA" & lr).Value2
According to the macro, loading into memory (a) starting in column B, means that in index 1 is column B, in index 2 is column C.

Select Case a(i, 3)
In that line, check index 3, but the letters "X", "Y", "Z" were stored in index 2. That is why the macro does not match with the data.

 

[kelly mort]

Okay

The code does not match with the image data on sheet1.
Are you sure that this is the last code and that the image is the data you work with?

a = Sheet1.Range("B7:AA" & lr).Value2
According to the macro, loading into memory (a) starting in column B, means that in index 1 is column B, in index 2 is column C.

Select Case a(i, 3)
In that line, check index 3, but the letters "X", "Y", "Z" were stored in index 2. That is why the macro does not match with the data.

Okay

Sorry about that.

This is Sheet1

Please look at post #5 for the rules I used .

Thanks

 

[DanteAmor]

Try this

Sub test()
  Dim lr As Long, a As Variant, b As Variant, c As Variant, sufix As String
  Dim i As Long, j As Long, k As Long, nSum As Double, nRank As Long
  Dim nID As Variant, nMax As Double, sCat As String, f As Range
  
  nID = Val(UserForm1.txtID.Value)

  Set f = Sheet1.Range("B:B").Find(nID, , xlValues, xlWhole)
  If Not f Is Nothing Then
    sCat = f.Offset(, 2)
  End If
  
  lr = Sheet2.Range("B" & Rows.Count).End(3).Row
  a = Sheet1.Range("B7:AA" & lr).Value2
  ReDim b(1 To UBound(a, 1), 1 To 11)
  ReDim c(1 To 1, 1 To 10)
  
  For i = 1 To UBound(a)
    nSum = 0
    For j = 7 To 16
      Select Case a(i, 3)
        Case "X", "Y", "Z"
          b(i, j - 6) = a(i, j) + a(i, j + 10) * 0.2
        Case Else
          b(i, j - 6) = a(i, j) + a(i, j + 10) * 0.1
      End Select
      nSum = nSum + b(i, j - 6)
    Next
    b(i, 11) = nSum
    If a(i, 1) = nID Then
      For k = 1 To 10
        c(1, k) = b(i, k)
      Next
      nMax = nSum
    End If
  Next
  
  nRank = 1
  For i = 1 To UBound(b)
    If a(i, 3) = sCat And b(i, 11) > nMax Then
      nRank = nRank + 1
    End If
  Next
  
  Select Case nRank
    Case 11 To 13
      sufix = "th"
    Case Else
      Select Case Right(nRank, 1)
        Case "1": sufix = "st"
        Case "2": sufix = "nd"
        Case "3": sufix = "rd"
        Case Else: sufix = "th"
      End Select
  End Select
  UserForm1.txtRank.Value = nRank & " " & sufix
  
  
  For j = 1 To 10
    nRank = 1
    For i = 1 To UBound(b)
      If a(i, 3) = sCat And b(i, j) > c(1, j) Then
        nRank = nRank + 1
      End If
    Next
    Select Case nRank
      Case 11 To 13
        sufix = "th"
      Case Else
        Select Case Right(nRank, 1)
          Case "1": sufix = "st"
          Case "2": sufix = "nd"
          Case "3": sufix = "rd"
          Case Else: sufix = "th"
        End Select
    End Select
    UserForm1.Controls("tb" & j).Value = nRank & " " & sufix
  Next
  
End Sub

 

[kelly mort]

You are very intelligent.

Thanks a lot. Have a wonderful time

 

[DanteAmor]

Again with pleasure. Thanks for the feedback

 

[kelly mort]

Hi again @DanteAmor,

One last request on this thread and I will take a break.

I have another set of textboxes; txtAve1 to txtAve11 .

They are to take the average of the category ranked .

So assuming the nID has an X category, then the textboxes txtAve1 to txtAve11 are to take the averages of category X across the 11 columns of data as we have been working on some far.

Since the current calculations is keeping zeros, I will be glad if you can avoid the zeros taking part of the average.

Thanks

 

[DanteAmor]

So assuming the nID has an X category, then the textboxes txtAve1 to txtAve11 are to take the averages of category X across the 11 columns of data as we have been working on some far.

In post #32 you put an image, you can explain it using that example data.

 

[kelly mort]

In post #32 you put an image, you can explain it using that example data.

What I mean is that say the nID 378 as from the image in post #32, we find the average of the X category. Since the 378 has X as its category.

So txtAve1 to txtAve10 should take averages for the first 10 columns of our stored number columns.

Then txtAve11 takes the 11th column, which is our total for the 10 columns.

And taking 378 as nID, we saw that when we process that row, we get zeros as output. And when we factor that in our average, the value will be distorted a bit.

So I will want you to take care of that situation by eliminating the zeros in the calculation of the average.

I hope this is a cooler explanation.

Regards

 

[DanteAmor]

I hope this is a cooler explanation.

you can explain it using that example data.

What I would like in the explanations are examples using values.
average (23.6 + 29.6 + 56) = 34.6

That is what I mean by examples. But you must use the image data, perform the calculations and explain the results. All examples must be presented with values and results.

Try this:

Sub test()
  Dim lr As Long, a As Variant, b As Variant, c As Variant, sufix As String
  Dim i As Long, j As Long, k As Long, nSum As Double, nRank As Long
  Dim nID As Variant, nMax As Double, sCat As String, f As Range
  Dim nTot As Double, nCon As Long
  
  nID = Val(UserForm1.txtID.Value)

  Set f = Sheet1.Range("B:B").Find(nID, , xlValues, xlWhole)
  If Not f Is Nothing Then
    sCat = f.Offset(, 2)
  End If
  
  lr = Sheet2.Range("B" & Rows.Count).End(3).Row
  a = Sheet1.Range("B7:AA" & lr).Value2
  ReDim b(1 To UBound(a, 1), 1 To 11)
  ReDim c(1 To 1, 1 To 10)
  
  For i = 1 To UBound(a)
    nSum = 0
    For j = 7 To 16
      Select Case a(i, 3)
        Case "X", "Y", "Z"
          b(i, j - 6) = a(i, j) + a(i, j + 10) * 0.2
        Case Else
          b(i, j - 6) = a(i, j) + a(i, j + 10) * 0.1
      End Select
      nSum = nSum + b(i, j - 6)
    Next
    b(i, 11) = nSum
    If a(i, 1) = nID Then
      For k = 1 To 10
        c(1, k) = b(i, k)
      Next
      nMax = nSum
    End If
  Next
  
'RANKS
  nRank = 1
  For i = 1 To UBound(b)
    If a(i, 3) = sCat And b(i, 11) > nMax Then
      nRank = nRank + 1
    End If
  Next
  
  Select Case nRank
    Case 11 To 13
      sufix = "th"
    Case Else
      Select Case Right(nRank, 1)
        Case "1": sufix = "st"
        Case "2": sufix = "nd"
        Case "3": sufix = "rd"
        Case Else: sufix = "th"
      End Select
  End Select
  UserForm1.txtRank.Value = nRank & " " & sufix
  
  For j = 1 To 10
    nRank = 1
    For i = 1 To UBound(b)
      If a(i, 3) = sCat And b(i, j) > c(1, j) Then
        nRank = nRank + 1
      End If
    Next
    Select Case nRank
      Case 11 To 13
        sufix = "th"
      Case Else
        Select Case Right(nRank, 1)
          Case "1": sufix = "st"
          Case "2": sufix = "nd"
          Case "3": sufix = "rd"
          Case Else: sufix = "th"
        End Select
    End Select
    UserForm1.Controls("tb" & j).Value = nRank & " " & sufix
  Next

'AVERAGE
  For j = 1 To 11
    nTot = 0
    nCon = 0
    For i = 1 To UBound(b)
      If a(i, 3) = sCat And b(i, j) > 0 Then
        nTot = nTot + b(i, j)
        nCon = nCon + 1
      End If
    Next
    UserForm1.Controls("txtAve" & j).Value = nTot / nCon
  Next
End Sub

 

[kelly mort]

You nailed it right on the head.

I really appreciate it.

Now my codes are having touches of professionalism.
Hahaha