I have the following code in VBA to find the last cell inside a range that is greater than 0:
Set myRange = .Range(.Cells(1, 14), .Cells(1, 23))
count = 0 'Counter
For Each cll In myRange
If cll.Value > 0 Then
count = count + 1
NoZeroDir = cll.Address
End If
Next
It gets the address of the last cell greater than 0 in that range.
But, how could I get the address from the cell greater than 0 before this last one?
I was thinking of using an offset but that way I'd get the cell before the last > 0 but this cell could not be > 0.
To illustrate it a bit, as an example I have:
2 3 5 0 1 7 0 8 1 0 1
The address from the last cell > 0 would be (1,11) but I want the cell before that one > 0, that is (1,9), not (1,10) as this is 0.
To find the second last number that is >0
Option Explicit
Public Sub FindSecondLastValueGreaterZero()
Dim MyRange As Range
Set MyRange = Range("A1:K1")
Const MAXSKIPS As Long = 1 ' skip 1 number that is >0
Dim Skips As Long
Dim iCol As Long
For iCol = MyRange.Columns.Count To 1 Step -1
If MyRange(1, iCol).Value > 0 And Skips < MAXSKIPS Then
Skips = Skips + 1
ElseIf MyRange(1, iCol).Value > 0 Then
Debug.Print "Found at: " & MyRange(1, iCol).Address
Exit For
End If
Next iCol
End Sub
This will start in K loop backwards until it finds a 0 then keeps doing it until skipped >0 is 1 and print the address I1 as result.
Since this loops backwards from right to left it should find the result (in most cases) faster than your code.
Alternative using Worksheetfunction Filter() (vs. MS 365)
Based upon the newer WorksheetFunction Filter() (available since version MS/Excel 365) and using OP's range indication
=FILTER(COLUMN(A1:K1),A1:K1>0)
you are able to get an array of column numbers from cells greater than zero (0) via an evaluation of the generalized formula pattern.
If you get at least two remaining columns (i.e. an upper boundary UBound() > 1) you get the wanted 2nd last column number by i = cols(UBound(cols) - 1) and can translate it into an address via Cells(1, i).Address.
Public Sub SecondLastValGreaterZero()
'a) construct formula to evaluate
Const FormulaPattern As String = "=FILTER(COLUMN($),$>0)"
Dim rng As Range
Set rng = Sheet1.Range("A1:K1") ' << change to your needs
Dim myFormula As String
myFormula = Replace(FormulaPattern, "$", rng.Address(False, False, external:=True))
'b) get tabular column numbers via Evaluate
Dim cols As Variant
cols = Evaluate(myFormula)
'c) get the 2nd last column number of cell values > 0
Dim i As Long
If Not IsError(cols) Then
If UBound(cols) > 1 Then i = cols(UBound(cols) - 1)
End If
'd) display result
If i > 0 Then
Debug.Print "Found at column #" & i & ": " & Cells(1, i).Address
Else
Debug.Print "Invalid column number " & CStr(i)
End If
End Sub
Example result in VB Editor's immediate window
Found at column #9: $I$1
I am having trouble determining a way to enter a 1 or 0 into an adjacent cell to indicate whether or not a value is unique when working with a large dataset. I have read of multiple methods for accomplishing this, however none of them seem efficient for my purposes: I am using an instance of Excel 2010 (so I do not have the Distinct Count feature in PivotTables, and when I try to use PowerPivot it crashes my file due to processing limitations.
In this StackOverflow question: Simple Pivot Table to Count Unique Values there are suggestions to use SUMPRODUCT or COUNTIF, but when working with 50,000+ rows as I am, this causes terrible performance and a file size of ~35 MB instead of ~3 MB. I wanted to know if there is a better solution for a large, dynamic dataset whether it is a formula or VBA.
An example of what I would like to accomplish is (with the Unique column being the adjacent cell):
Name Week Unique
John 1 1
Sally 1 1
John 1 0
Sally 2 1
I attempted to script the same functionality of COUNTIF but with no success:
For Each Cell In ThisWorkbook.Worksheets("Overtime & Type Data").Range("Z2:Z" & DataLastRow)
If Worksheets("Overtime & Type Data").Cells(Cell.Row, 26) <> Worksheets("Overtime & Type Data").Cells(Cell.Row - 1, 26) Then
FirstCell = Cell.Row
End If
If (Worksheets("Overtime & Type Data").Range(Cells(FirstCell, 26), Cells(Cell.Row, 26)) = Worksheets("Overtime & Type Data").Range(Cells(Cell.Row, 26))) = True Then
Cell.Value = 1
Else
Cell.Value = 0
End If
Next Cell
This code ran on over 130,000 rows successfully in less than 3 seconds. Adjust the column letters to fit your dataset.
Sub tgr()
Const colName As String = "A"
Const colWeek As String = "B"
Const colOutput As String = "C"
Dim ws As Worksheet
Dim rngData As Range
Dim DataCell As Range
Dim rngFound As Range
Dim collUniques As Collection
Dim arrResults() As Long
Dim ResultIndex As Long
Dim UnqCount As Long
Set ws = ThisWorkbook.Sheets("Overtime & Type Data")
Set rngData = ws.Range(colName & 2, ws.Cells(Rows.Count, colName).End(xlUp))
Set collUniques = New Collection
ReDim arrResults(1 To rngData.Cells.Count, 1 To 1)
On Error Resume Next
For Each DataCell In rngData.Cells
ResultIndex = ResultIndex + 1
collUniques.Add ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value, ws.Cells(DataCell.Row, colName).Value & ws.Cells(DataCell.Row, colWeek).Value
If collUniques.Count > UnqCount Then
UnqCount = collUniques.Count
arrResults(ResultIndex, 1) = 1
Else
arrResults(ResultIndex, 1) = 0
End If
Next DataCell
On Error GoTo 0
ws.Cells(rngData.Row, colOutput).Resize(rngData.Cells.Count).Value = arrResults
End Sub
One approach is to sort by Name and Week. Then you can determine Unique for any row by comparing with the previous row.
If you need to preserve the order, you could first write a column of Index numbers (1, 2, 3, ...) to keep track of order. After calculating Unique, sort by Index to restore the original order.
The whole process could be done manually with relatively few steps, or automated with VBA.
I'm not sure how well this will work with 50000 values, but it goes through ~1500 in about a second.
Sub unique()
Dim myColl As New Collection
Dim isDup As Boolean
Dim myValue As String
Dim r As Long
On Error GoTo DuplicateValue
For r = 1 To Sheet1.UsedRange.Rows.Count
isDup = False
'Combine the value of the 2 cells together
' and add that string to our collection
'If it is already in the collection it errors
myValue = Sheet1.Cells(r, 1).Value & Sheet1.Cells(r, 2).Value
myColl.Add r, myValue
If isDup Then
Sheet1.Cells(r, 3).Value = "0"
Else
Sheet1.Cells(r, 3).Value = "1"
End If
Next
On Error GoTo 0
Exit Sub
DuplicateValue:
'The value is already in the collection so put a 0
isDup = True
Resume Next
End Sub
Just about any bulk operation will beat a loop involving worksheet cells. You might be able to trim the time down a bit by performing all of the calculations in memory and only returning the values back to the worksheet en masse when it is complete.
Sub is_a_dupe()
Dim v As Long, vTMP As Variant, vUNQs As Variant, dUNQs As Object
Debug.Print Timer
On Error GoTo bm_Uh_Oh
Set dUNQs = CreateObject("Scripting.Dictionary")
With Worksheets("Sheet1")
vTMP = .Range(.Cells(2, 1), .Cells(Rows.Count, 2).End(xlUp)).Value2
ReDim vUNQs(1 To UBound(vTMP, 1), 1 To 1)
For v = LBound(vTMP, 1) To UBound(vTMP, 1)
If dUNQs.Exists(Join(Array(vTMP(v, 1), vTMP(v, 2)))) Then
vUNQs(v, 1) = 0
Else
dUNQs.Add Key:=Join(Array(vTMP(v, 1), vTMP(v, 2))), _
Item:=vTMP(v, 2)
vUNQs(v, 1) = 1
End If
Next v
.Cells(2, 3).Resize(UBound(vUNQs, 1), 1) = vUNQs
End With
Debug.Print Timer
bm_Uh_Oh:
dUNQs.RemoveAll
Set dUNQs = Nothing
End Sub
Previous experience tells me that the variety of data (as well as hardware, etc) will impact timing the process but in my random sample data I received these elapsed times.
50K records ..... 0.53 seconds
130K records .... 1.32 seconds
500K records .... 4.92 seconds
How do I have to change the following macro code and formula which works for the data and question below(earlier data/question,column F) to make it suitable for Problemstatement (2) and (3) ?
(1)
Earlier data
Colums C,D,E,F
Row 1 4,10,40,F
Row 2 4,12,48,F
Row 3 4,14,56,F
Row 4 3,16,48,F
Row 5 1,18,18,F
Row 6 1,20,10,F
Row 7 0,22,0,0
Intention of the column F
If Cx <> 0, Fx = Cx
If Cx = 0, Fx = the address of the cell in Column C that produces minimum of (C1 * D7 - E1, C2 * D7 - E2, ..., CN * D7 - EN) and is >0.
** Macro code and formula for column F**
Public Function MinimumC()
Dim rngCurrent As Range
Set rngCurrent = Application.ThisCell
Dim rngMin As Range
Dim minimum As Long
minimum = 100000000
Dim tmp As Long
Dim rngC As Range
Set rngC = ActiveSheet.Range("C1:C" & rngCurrent.Row - 1)
For Each c In rngC.Cells
If c.Value2 <> 0 Then
tmp = c.Value2 * rngCurrent.Offset(0, -2).Value2 - c.Offset(0, 2)
If tmp < minimum Then
minimum = tmp
Set rngMin = c
End If
End If
Next c
MinimumC = rngMin.Value2
End Function
Formula in F1 and copy down column F: =IF(C1<>0,C1,MinimumC())
(2)
How do I have to change the macro and formula to archieve the same in the following data format:
New data 1
Colums AZ,BA,BB,BC,BD,BE,BF,BG
Row 1 4,4,4,10,10,10,120,444
Row 2 4,4,4,12,12,12,144,444
Row 3 4,4,4,14,14,14,168,444
Row 4 3,3,3,16,16,16,144,333
Row 5 1,1,1,18,18,18,54,111
Row 6 1,1,1,20,20,20,60,111
Row 7 0,0,0,22,22,22,0,???
Intention of the column BG
If(And(AZ>0;BA>0;BB>0);Concatenate(AZ;BA;BB))
otherwise, the adress cell of Concatenate (AZ;BA;BB), unequal to 000, to minimize the following difference (AZn*BCx+BAn*BDx+BBn*BEx)-BFn
(3)
How do I have to change the macro and formula from (1) to archieve the same in the following data format:
New data 2
Colums AZ,BA,BB,BC,BD,BE,BF,BG,BH,BI,BJ,BK,BL,BM,BN
Row 1 4,4,4,10,10,10,120,444,3,3,3,10,10,10,90,333
Row 2 4,4,4,12,12,12,144,444,3,3,3,12,12,12,108,333
Row 3 4,4,4,14,14,14,168,444,3,3,3,14,14,14,126,333
Row 4 3,3,3,16,16,16,144,333,3,3,3,16,16,16,144,333
Row 5 1,1,1,18,18,18,54,111,2,2,2,18,18,18,108,222
Row 6 1,1,1,20,20,20,60,111,1,1,1,20,20,20,60,111
Row 7 0,0,0,22,22,22,0,?,0,0,0,22,22,22,0,?
Intention of the column BN
If(And(AZ>0;BA>0;BB>0;BH>0;BI>0;BJ>0);0
otherwise the adress of the cell either concatenate (AZ;BA;BB) or concatenate (BH;BI;BJ) to minimize (AZn*BCx+BAn*BDx+BBn*BEx)-BFn or (BHn*BKx+BIn*BLx+BJn*BMx)-BNn .In this case i need to find the adress of either concatenate (AZ;BA;BB) or concatenate (BH;BI;BJ) with the min difference and that cell of BN (concatenate) unequal to 000.
I appriciate the help. Thank you very much!!!!
To solve problem 2, the macro is basically identical. You just need to replace the C range with the AZ range, and change the calculation of tmp:
Public Function CalcBG()
Dim rngCurrent As Range
Set rngCurrent = Application.ThisCell
Debug.Print rngCurrent.Address
Dim rngMin As Range
Dim minimum As Long
minimum = 100000000
Dim tmp As Long
Dim rngAZ As Range
Set rngAZ = ActiveSheet.Range("AZ1:AZ" & rngCurrent.Row - 1)
Debug.Print rngAZ.Address
For Each c In rngAZ.Cells
If c.Value2 <> 0 Then
tmp = ((c.Value * rngCurrent.Offset(0, -4).Value2) + (c.Offset(0, 1).Value2 * rngCurrent.Offset(0, -3).Value2) + (c.Offset(0, 2).Value2 * rngCurrent.Offset(0, -2)) - c.Offset(0, 6).Value2) 'This is your calculation (AZn * BCx) + ... - BFn
If tmp < minimum Then
minimum = tmp
Debug.Print minimum
Set rngMin = c.Offset(0, 7)
Debug.Print rngMin
End If
End If
Next c
Debug.Print minimum
Debug.Print rngMin.Address
CalcBG = rngMin.Address 'Return the address rather than the value
End Function
And the formula:
=IF(AND(AZ1>0,BA1>0,BB1>0),CONCATENATE(AZ1,BA1,BB1),CalcBG())
Place that in BG1 and copy down Column BG.
Problem 3
This added a couple more variables, but the basic structure is the same.
Based on the data, I also assumed that "If(And(AZ>0;BA>0;BB>0;BH>0;BI>0;BJ>0);0" should have been If(And(AZ>0;BA>0;BB>0;BH>0;BI>0;BJ>0),concatenate(bh,bi,bj). Otherwise your values in BO would all be 0. Also, your last column is BO, not BN. :)
Here's the macro:
Public Function CalcBO()
Dim rngCurrent As Range
Set rngCurrent = Application.ThisCell
Debug.Print rngCurrent.Address
Dim rngMin As Range
Dim minimum As Long
minimum = 100000000
Dim tmp1 As Long
Dim tmp2 As Long
Dim lowest As Long
Dim rngAZ As Range
Set rngAZ = ActiveSheet.Range("AZ1:AZ" & rngCurrent.Row - 1)
Debug.Print rngAZ.Address
For Each c In rngAZ.Cells
If c.Value2 <> 0 Then
'(AZn*BCx+BAn*BDx+BBn*BEx)-BFn
tmp1 = ((c.Value2 * rngCurrent.Offset(0, -12).Value2) + (c.Offset(0, 1).Value2 * rngCurrent.Offset(0, -13).Value2) + (c.Offset(0, 2).Value2 * rngCurrent.Offset(0, -10).Value2)) - c.Offset(0, 6).Value2
'(BHn*BKx+BIn*BLx+BJn*BMx)-BNn
tmp2 = ((c.Offset(0, 8).Value2 * rngCurrent.Offset(0, -4).Value2) + (c.Offset(0, 9).Value2 * rngCurrent.Offset(0, -3).Value2) + (c.Offset(0, 10).Value2 * rngCurrent.Offset(0, -2).Value2)) - c.Offset(0, 14).Value2
lowest = WorksheetFunction.Min(tmp1, tmp2)
If lowest < minimum Then
minimum = lowest
Debug.Print minimum
Set rngMin = c.Offset(0, 7)
Debug.Print rngMin
End If
End If
Next c
Debug.Print minimum
Debug.Print rngMin.Address
CalcBO = rngMin.Address
End Function
And here is the formula for BO1. Copy down as usual:
=IF(AND(AZ1>0,BA1>0,BB1>0,BH1>0,BI1>0,BJ1>0),CONCATENATE(BH1,BI1,BJ1),CalcBO())
There's a lot of repetition among those macros, and they could probably be condensed. But they should do what you need.
One note: The macros won't differentiate between equal minimum values. For example, in problem set 3, the two calculations (AZn ... - BFn and BHn ... - BNn) return the same value, 6, which also happens to be the minimum value among all the calculations. In this case, it returns the first address (AZn ... - BFn). So in Problem 3, you will get the answer $BG$6 in BO7, even though $BG$6 and $BO$6 both satisfy the conditions. Your requirements didn't specify what to do in case there was more than one minimum value, so I left it as it is.
Let me know if you need any help with the above.
lets say in column A:Row 2, I have a score of 45 and in column B, I have the amount of people that got that score. what i then want to do is on column D, output that score X amount of times. x=repitition.
in the exmaple 5 people got a score of 45 so in column D i want to insert 5 scores of 45. then I see in column A:Row2 3 people got a score of 46 then after the last 45, in column D I want to append 46 3 times.. and so on..
Could someone show me how to do this?
Here you go:
Sub test_scores_repitition()
'run with test scores sheet active
r = 1
dest_r = 1
Do While Not IsEmpty(Range("a" & r))
If IsEmpty(Range("b" & r)) Then Range("b" & r).Value = 0 'if there's no quantity listed for a score, it assumes zero
For i = 1 To Range("b" & r).Value
Range("d" & dest_r).Value = Range("a" & r).Value
dest_r = dest_r + 1
Next i
r = r + 1
Loop
End Sub
Macro answer:
Sub WriteIt()
Dim lrow As Long
Dim WriteRow As Long
Dim EachCount As Long
Dim ReadRow As Long
' find last in list of numbers
lrow = Range("A1").End(xlDown).Row
'start at 2 because of headers
WriteRow = 2
ReadRow = 2
While ReadRow <= lrow
For EachCount = 1 To Cells(ReadRow, 2)
'repeat the number of times in column B
Cells(WriteRow, 4) = Cells(ReadRow, 1)
'the number in column A
WriteRow = WriteRow + 1
Next
ReadRow = ReadRow + 1
'and move to the next row
Wend
'finish when we've written them all
End Sub
it is possible with a formula, just not really recommended as it looks auful, and would be difficult to explain. It uses a Microsoft formula to count the number of unique items in the data above, and once it counts the number it is supposed to write of the number above, it moves to the next number. The formula does not know where to stop, and will put 0 when it runs out of data.
in D2, put =A2
In D3, and copied down, put
=IF(COUNTIF($D$2:D2,OFFSET($A$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1)),0))<OFFSET($B$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1)),0),OFFSET($A$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1)),0),OFFSET($A$1,SUM(IF(FREQUENCY($D$2:D2,$D$2:D2)>0,1))+1,0))