Related
I did some code and at some point i created an array and then use that array to feed a validation list in a cell, all work just fine but when i close the worksheet and then open it an error occur and i have to do some adjustment in order to use the macro again.
I read some tips on internet the easy way is to save the worksheet in binary mode, xlsb, the error occur but the worksheet is usable you have just to relaunch the macro.
what i was wondering is, is there a way to deal with this problem once for all?
here the screenshot about the error
here the description
here the code about the list
Sub filtroSwing()
Dim mezzi As New Collection
Dim tot As Range
Set tot = Foglio3.Range("a1:a" & Foglio3.Cells(Rows.Count, 1).End(xlUp).Row)
On Error Resume Next
For i = 1 To tot.Rows.Count
mezzi.Add tot.Cells(i, 1).Value, tot.Cells(i, 1).Value
Next i
On Error GoTo 0
Dim lista() As Variant
ReDim lista(1 To mezzi.Count)
Dim temp As String
For i = 1 To mezzi.Count
lista(i) = mezzi(i)
Next i
'ordina
For i = 1 To mezzi.Count - 1
For j = i + 1 To mezzi.Count
If lista(i) > lista(j) Then
temp = lista(i)
lista(i) = lista(j)
lista(j) = temp
End If
Next j
Next i
Foglio7.Range("f1").Validation.Delete
Foglio7.Range("f1").Validation.Add xlValidateList, Formula1:=Join(lista, ",")
Foglio6.Range("u22").Validation.Delete
Foglio6.Range("u22").Validation.Add xlValidateList,Formula1:=Join(lista, ",")
end sub
thanks in advance
Cristiano
If Join(lista, ",") > then 255 characters, you will also have problems.
I suggest:
create sorted lista as you have, but as a 2D array eg lista(1 to mezzi.count, 1 to 1)
write lista to a range on a hidden worksheet.
myRange = lista
then .Formula1 = myRange
I am trying to set up Job assignments for my 11 employees randomly from 8 tasks daily. Out of the 8 tasks, one needs to be selected 4 times, one needs to be selected 2 times and the other six tasks need only be selected once. Since there are only 8 tasks and 11 employees, some of the six single selected tasks can be selected twice. I have been trying to use a weighted system and it works "ok" but I feel there should be a way to do what I want while still using the weighted system (maybe not), I just can not figure out how to set the limit of each randomly selected item. Any help would be greatly appreciated.
I've tried For loops, Case, and IF/Then, but can not get anything to work. The code I have listed currently works to make the random selections but sometimes gets into having too many or too little of one item or more.
Option Explicit
Private Sub CommandButton1_Click()
Dim RandomName As String
Dim Row As Long
Dim R As Range
Dim cell As Range
Dim upperBound As Integer
Dim lowerBound As Integer
'RandomName = Range("I2").value
Set R = Range("I2:I12")
'upperBound = 20
'lowerBound = 5
'RandomName = WeightedRnd(Array("Lamination", "Metro", "Final Insp", "AGL", "iEcho", "LPN", "Confocal", "Hardness"), Array(20, 18, 20, 8, 8, 10, 5, 11))
For Each cell In R
cell.value = WeightedRnd(Array("Lamination", "Metro", "Final Insp", "AGL", "iEcho", "LPN", "Confocal", "Hardness"), Array(25, 17, 19, 7, 8, 9, 5, 10))
' If RandomName Like "*Lamination*" = 4 Then
' cell.value = WeightedRnd(Array("Metro", "Final Insp", "AGL", "iEcho", "LPN", "Confocal", "Hardness"), Array(25, 25, 10, 10, 10, 5, 15))
'cell.value = RandomName 'Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
' End If
'Worksheets("Crew").Cells(Row, 1).value = RandomName
Next cell
'Range("I2", Row + 1, 11).value = RandomName
End Sub
Function WeightedRnd(items As Variant, weights As Variant) As Variant
Dim myItems(1 To 100) As Variant
Dim weight As Variant
Dim item As Variant
Dim myNumber As Variant
Dim i As Integer
Dim n As Integer
Dim p As Integer
Dim pick As Integer
i = 1
n = 0
For Each weight In weights
For p = 1 To weight
myItems(i) = items(n)
i = i + 1
Next
n = n + 1
Next
n = UBound(myItems) - LBound(myItems) + 1
pick = getRandom(1, n)
WeightedRnd = myItems(pick)
End Function
Function getRandom(lowerBound, upperBound)
Randomize
getRandom = Int((upperBound - lowerBound + 1) * Rnd + lowerBound)
End Function
Instead of considering 8 tasks in a list, consider 12 tasks (of which some are duplicates). Depending on your needs, you may want to consider two lists - the first 6 are the two duplicated tasks, and then the remaining 6 are the singular tasks. How you split this up depends on your limits and criteria.
Now, you can randomly select from the lists (removing an item from the list once selected) and meet your limits/criteria.
Thanks for everyone taking a look and trying to help. As AJD pointed out, try a different route to get what I want, so that's what I did and found the answer I needed at: https://answers.microsoft.com/en-us/msoffice/forum/all/vba-coding-help-random-selection-from-list-without/f281278d-1acc-47c0-8f1b-7054bd6d538a.
Code here:
Sub RangeRandomize()
Dim SrcRange As Range, FillRange As Range
Dim c As Range, r As Long
Set SrcRange = Application.InputBox("Select source names", Type:=8)
Set FillRange = Application.InputBox("Select Fill range", Type:=8)
If FillRange.Cells.Count > SrcRange.Cells.Count Then
MsgBox "Fill range too large"
Exit Sub
End If
r = SrcRange.Cells.Count
For Each c In FillRange
Do
c.Value = WorksheetFunction.Index(SrcRange, Int((r * Rnd) + 1))
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
Changing the SrcRange and FillRange to specific ranges and adding a clear contents line is giving me what I need.
Thank all!
I wrote a function that supposed to get a specific part of a specific Column, and then, by comparing each entry of the column to the value of the cell that is left to it, count the times a specific condition is met.
It all works alright, except one problem.. if I use the function on "Sheet1", get a result and then switch to "Sheet2" and use the function on this sheet it changes the result on "Sheet1" for some reason.
Function countStable(rangeObj As Range) 'rangeObj that being passed is a namedRange(Synamic Range)
Application.Volatile
ActiveSheet.Select
Dim entry, preEntryVal, entryVal As Variant
Dim counters(1 To 5, 1 To 1) As Integer
Dim cStable, cIncreased, cDecreased, cAdded, cLost
cStable = 0
cIncreased = 0
cDecreased = 0
cAdded = 0
cLost = 0
Set rangeObj = Intersect(rangeObj, rangeObj.Parent.UsedRange)
For Each entry In rangeObj
If Not IsEmpty(entry.Value) And Not IsEmpty(ActiveSheet.Range("A" & entry.Row)) Then
entryVal = entry.Value
preEntryVal = ActiveSheet.Cells(entry.Row, entry.Column - 1).Value
If entryVal = preEntryVal Then
cStable = cStable + 1
ElseIf InStr(entryVal, "-") And Not (InStr(preEntryVal, "-")) Then
cLost = cLost + 1
ElseIf Not InStr(entryVal, "-") And InStr(preEntryVal, "-") Then
cAdded = cAdded + 1
ElseIf preEntryVal < entryVal Then
cDecreased = cDecreased + 1
ElseIf preEntryVal > entryVal Then
cIncreased = cIncreased + 1
End If
End If
counters(1, 1) = cStable
counters(2, 1) = cIncreased
counters(3, 1) = cDecreased
counters(4, 1) = cAdded
counters(5, 1) = cLost
Next
countStable = counters
End Function
As commented inside the code, rangeObj that is being passed as parameter was defined in the name manager and it is based on an Offset formula.
I know it changes the values on both sheets because of the dynamic range, but not sure why.. I don't want it to be changed.
Help please?
In several places, the code references the ActiveSheet. Wherever the function appears, it will reflect the value of whatever sheet is active. You'll want to use the parent of the supplied range object instead.
Dim currentSheet as Worksheet
Set currentSheet = rangeObj.Parent
Then, search and replace ActiveSheet with currentSheet in the method.
Very simple vba problem, not sure where it is going wrong, but:
Range("J21").Select
For tastetherainbow = 1 To 1000
skittle = ActiveCell.Offset(0, 2).Value
Selection.Interior.Color = skittle
ActiveCell.Offset(1, 0).Select
Next
The cell containing each appropriate skittle value contains an RGB code in the form RGB(r,g,b) , exactly as it should be for the VBA. I have tested it by copy pasting the cell's value into Selection.Interior.Color = paste without issue, but I get a "type mismatch" when it just uses skittle.
In fact, the only reason I am using skittle as a variable is that I had the same issue when I used Selection.Offset(0,2).Value to set the colour.
Rather lost! Could you let me know how to fix it, and why I have this issue.
Thanks!
It's recommended not using Select , Selection and ActiveCell , instead I preffer to start the For loop from Cell "J21" and just advance the row by 1.
Code
Option Explicit
Sub CellColors()
Dim Skittle As Long
Dim tastetherainbow As Long
' modify "Sheet1" to your sheet's name
With Sheets("Sheet1")
For tastetherainbow = 1 To 1000
Skittle = .Cells(tastetherainbow + 20, "L").Value
.Cells(tastetherainbow + 20, "J").Interior.Color = Skittle
Next tastetherainbow
End With
End Sub
Edited Code: converts the cell string format of "RGB(0,0,74)" to 0,0,74, then using the Split function putting the Strings into 3 elements of an array.
Then calculating Skittle Long numeric value using CInt and the RGB method.
Option Explicit
Sub CellColors()
Dim Skittle As Long
Dim CellRGBStr As String
Dim RGBInd() As String
Dim tastetherainbow As Long
With Sheets("Sheet3")
For tastetherainbow = 1 To 1000
If .Cells(tastetherainbow + 20, "L").Value <> "" Then
' use a string to store the "RGB(0,0,74)" as 0,0,74
CellRGBStr = Mid(.Cells(tastetherainbow + 20, "L").Value, 6, Len(.Cells(tastetherainbow + 20, "L").Value) - 7)
' split the CellRGBStr to 3 array elements
RGBInd = Split(CellRGBStr, ",")
' calculate the value of Skittle (using the RGB method)
Skittle = (CInt(RGBInd(0))) ^ 3 + (CInt(RGBInd(1))) ^ 2 + (CInt(RGBInd(2))) ^ 1
.Cells(tastetherainbow + 20, "J").Interior.Color = Skittle
End If
Next tastetherainbow
End With
End Sub
Another way to calculate Skittle is with the RGB function:
Skittle = RGB(CInt(RGBInd(0)), CInt(RGBInd(1)), CInt(RGBInd(2)))
Thanks for all the help guys, I modified it and cheated a little... This is running as part of a much larger macro, so I decided to just make the array of R, G, and B values explicit, and do it this way. From reading online Victor it says that RGB() expects values as integers - Long is more efficient but does the same thing nowadays no? Here is a working version. Couldn't have done it without you both thank you very much!
Sub ColourMeImpressed()
Dim Skittler As Long
Dim Skittleg As Long
Dim Skittleb As Long
Dim tastetherainbow As Long
With Sheets("Converter")
For tastetherainbow = 21 To 1000
Skittler = .Cells(tastetherainbow, "G")
Skittleg = .Cells(tastetherainbow, "H")
Skittleb = .Cells(tastetherainbow, "I")
Skittle = RGB(Skittler, Skittleg, Skittleb)
.Cells(tastetherainbow, "J").Interior.Color = Skittle
Next tastetherainbow
End With
End Sub
For those interested, here is a screenshot of the final result:
'little modification is required in your code as follows
Range("J21").Select
For tastetherainbow = 1 To 1000
skittle = ActiveCell.Offset(0, 2).Value
Selection.Interior.Color = RGB(skittle)
ActiveCell.Offset(1, 0).Select
Next
Hi everyone, by using an array formulas to calculate (in the above example):
Count unique customers that had purchased only less than 5 units of only product 1 which area code match only with the adjacent D cells
I Use the following array formula to be in E11:
=SUM(IF(FREQUENCY(IF($G$2:$G$7=D11,
IF($I$2:$I$7="Product 1",IF($J$2:$J$7<5,IF($E$2:$E$7<>"",
MATCH($E$2:$E$7,$E$2:$E$7,0))))),ROW($E$2:$E$7)-ROW(G2)+1),1))
this formula doing great, at the same time when using it thru very huge database containing tons of rows and columns, excel takes a bout 3 minutes to calculate only one cell which is terrible to continue like that
is there any way to convert this array formula to regular one ... any help will be appreciated to the maximum ... Thanks in advance
Sorry for the late answer.
I created an UDF which is focused on doing the calculation several times without running the whole range multiple times.
Public Function getCounts(AreaStr As Variant, AreaRng As Range, CustomerRng As Range, ProductRng As Range, SalesRng As Range, Optional ProductName As String = "Product 1", Optional lessThan As Double = 5) As Variant
'make sure AreaStr is an array
If TypeOf AreaStr Is Range Then AreaStr = AreaStr.Value2
If Not IsArray(AreaStr) Then
AreaStr = Array(AreaStr)
ReDim Preserve AreaStr(1 To 1)
End If
'shorten the range (this way you can use whole columns)
If SalesRng(SalesRng.Cells.Count).Formula = "" Then Set SalesRng = SalesRng.Parent.Range(SalesRng.Cells(1), SalesRng(SalesRng.Cells.Count).End(xlUp))
'make sure all ranges have the same size
Set AreaRng = AreaRng.Resize(SalesRng.Rows.Count)
Set CustomerRng = CustomerRng.Resize(SalesRng.Rows.Count)
Set ProductRng = ProductRng.Resize(SalesRng.Rows.Count)
'Load values in variables to increase speed
Dim SalesValues As Variant, UserValues As Variant, ProductValues As Variant
SalesValues = AreaRng
UserValues = CustomerRng
ProductValues = ProductRng
'create temporary arrays to hold the values
Dim buffer() As Variant, expList() As Variant
ReDim buffer(1 To UBound(UserValues))
ReDim expList(1 To UBound(AreaStr), 1 To 1)
Dim i As Long, j As Double, k As Long
For i = 1 To UBound(AreaStr)
expList(i, 1) = buffer
Next
buffer = Array(buffer, buffer)
buffer(0)(1) = 0
For i = 1 To UBound(UserValues)
If ProductValues(i, 1) = ProductName Then 'this customer purchased our product
j = Application.IfError(Application.Match(UserValues(i, 1), buffer(0), 0), 0)
If j = 0 Then 'first time this customer in this calculation
j = i
buffer(0)(j) = UserValues(i, 1) 'remember the customer name (to not calculate him again later)
If Application.SumIfs(SalesRng, CustomerRng, UserValues(i, 1), ProductRng, ProductName) < lessThan Then
buffer(1)(j) = 1 'customer got less than "lessThan" -> remember that
End If
End If
If buffer(1)(j) = 1 Then 'check if we need to count the customer
k = Application.IfError(Application.Match(SalesValues(i, 1), AreaStr, 0), 0) 'check if the area is one of the areas we are looking for
If k Then expList(k, 1)(j) = 1 'it is -> set 1 for this customer/area combo
End If
End If
Next
For i = 1 To UBound(AreaStr) 'sum each area
expList(i, 1) = Application.Sum(expList(i, 1))
Next
getCounts = expList 'output array
End Function
I assume that you will be able to include it as an UDF without my help.
In the sheet you would use (for your example) E11:E16
=getCounts(D11:D15,G2:G7,E2:E7,I2:I7,J2:J7)
simply select the range of E11:E16 and enter the formula, then confirm it with CSE.
you also could use only =getCounts(D11,$G$2:$G$7,$E$2:$E$7,$I$2:$I$7,$J$2:$J$7) at E11 and then copy down... but that would be pretty slow.
The trick is, that we calculate the sum of the set for every customer, which at least bought it one time. Then we store 1 if it is less then your criteria. This goes for the general array. Every area you are looking for, will get its own array too. Here we also store the 1 at the same pos. As every costomer only gets calculated one time, having him multiple times doesn't matter.
the formula simply will be used like this:
getCounts(AreaStr,AreaRng,CustomerRng,ProductRng,SalesRng,[ProductName],[lessThan])
AreaStr: the area code you are looking for. should be an array of multiple cells to make the udf worth using it
AreaRng: the range where the area names are stored
CustomerRng: the range where the customer names are stored
ProductRng: the range where the product names are stored
SalesRng: the range where the sale counts are stored
ProductName (optional): the product you are looking for. Will be "Product 1" if omited
lessThan (optional): the trigger point for the sum of products. Will be 5 if omited
Most parts should be self explaining, but if you still have any questions, just ask ;)
OK, I am not sure of I understood all of the conditions and accumulation, but here is a VBA function that I think should do it.
First, open VBA from the Excel Developer menu. Then in VBA, create a new module from the Insert menu (just let it be Module1). Then paste the following 2 functions into the VBA module.
Public Function AreaUniqueCustomersLessThan(ReportAreaRange, AreaRange, ProductRange, SalesRange, CustomerRange)
On Error GoTo Err1
Dim RptAreas() As Variant
Dim Areas() As Variant, Products() As Variant, Sales() As Variant, Customers As Variant
RptAreas = ArrayFromRange(ReportAreaRange)
Areas = ArrayFromRange(AreaRange)
Products = ArrayFromRange(ProductRange)
Sales = ArrayFromRange(SalesRange)
Customers = ArrayFromRange(CustomerRange)
Dim r As Long, s As Long 'report and source rows indexes
Dim mxr As Long, mxs As Long
mxr = UBound(RptAreas, 1)
mxs = UBound(Areas, 1)
'encode the ReportAreasList into accumulation array indexes
Dim AreaCustomers() As Collection
Dim i As Long, j As Long
Dim colAreas As New Collection
ReDim AreaCustomers(1 To mxr)
For r = 1 To mxr
On Error Resume Next
'Do we have the area already?
j = colAreas(RptAreas(r, 1))
If Err.Number <> 0 Then
'Add a new area to the collection and array
i = i + 1
colAreas.Add i, RptAreas(r, 1)
Set AreaCustomers(i) = New Collection
j = i
End If
Next r
'now scan the source rows, accumulating distinct customers
' for any ReportAreas
For s = 1 To mxs
'is this row's Arera in the report Area list?
i = 0
On Error Resume Next
i = colAreas(Areas(s, 1))
On Error GoTo Err1
If i > 0 Then
'this is a report Area code, so check the conditions
If Products(s, 1) = "Product 1" Then
If Sales(s, 1) < 5 Then
On Error Resume Next 'just ignore any duplicate errors
AreaCustomers(i).Add Customers(s, 1), Customers(s, 1)
On Error GoTo Err1
End If
End If
End If
Next s
'finally, return to the report area codes, returning the distinct count
' of customers
Dim count() As Variant
ReDim count(1 To mxr, 1 To 1)
For r = 1 To mxr
count(r, 1) = AreaCustomers(colAreas(RptAreas(r, 1))).count
Next r
AreaUniqueCustomersLessThan = count ' "foo"
Exit Function
Err1:
AreaUniqueCustomersLessThan = "%ERR(" & Str(Err.Number) & ")%" & Err.Description
Exit Function
Resume
End Function
'handle all of the cases, checking and conversions to convert
' a variant range into an array of Variant(1 to n, 1 to 1)
' (we do this because it makes data access very fast)
Function ArrayFromRange(varRange As Variant)
Dim rng As Range
Dim A() As Variant
Set rng = varRange
'Check for degenerate cases
If rng Is Nothing Then
'do nothing
ElseIf rng.count = 0 Then
'do nothing
ElseIf rng.count = 1 Then
ReDim A(1 To 1, 1 To 1)
A(1, 1) = rng.Value
Else
A = rng.Value
End If
ArrayFromRange = A
End Function
Finally, go to your Array Formula area and paste in the following Array formula for the "Sales < 5" list: {=AreaUniqueCustomersLessThan(D$11:D$16, G$2:G$7, I$2:I$7,J$2:J$7,E$2:E$7)} Note that the first range must be the same length as the Array Formula range itself. And the other four ranges (the source data ranges) should all be the same length (they do not have to be the same length as the first range).