I am a novice of Vba.
I have been litteraly fighting all day with this bit of code:
Sub ComandsCompactVisualization()
Dim x, i As Integer
Dim CellToAnalyse As Range
x = 2
i = 0
For i = 0 To 5 Step 1
Set CellToAnalyse = Worksheets("Comandi").Cells(x + i, 2)
If Not CellToAnalyse.Font.ColorIndex = 2 Then
Worksheets("Comandi").Rows("x+i:2").Hidden = True
End If
Next i
End Sub
I am trying to hide all the rows that in cell (x+i,2) have not got red text.
I am almost there but... Rows does not seem to accept as content Rows("x+i:2").
I obtain Runtime error 13 "Type mismatch".
If I substitute its content with Rows("2:2") row 2 is deleted but I am not any more able to hide all the other rows that do not have red text in column 2.
Ideas?
Anything between quotes "like this" is just a string. To perform arithmetic on x you need to do this first, then concatenate it to the other part of the string. Like this:
.Rows((x + i) & ":2")
BTW Isn't red 3..?
Sub ComandsCompactVisualization()
Dim x as long, i As Long 'You must declare ALL variables (x was as variant in your code)
Dim CellToAnalyse As Range
dim WS as Worksheet
'x = 2 'if x is always the same value, no need to calculate it each loop
'i = 0 'numbers are initialized to be 0, strings to be "", boolean to be false.
set WS=Sheets("Commandi")
For i = 0 To 5 ' Step 1
Set CellToAnalyse = WS.Cells(2 + i, 2)
If CellToAnalyse.Font.ColorIndex <> 2 Then
CellToAnalyse.entirerow.hidden=true
' WS.Rows(2+i).entirerow.hidden = true is the same result
End If
Next i
End Sub
Related
I am having trouble getting Variants to subtract. I am pulling data from a spreadsheet and if one cell states a phrase then I need the code to subtract one cell from another. If the cell does not state a phrase then I need it to copy one cell to another. I can get the code to run but nothing happens.
Private Sub CommandButton1_Click()
Dim x As Variant, y As Variant, z As Variant, a As Integer, B As String
'getting values for data
x = Range("D2:D48").Value
y = Range("I2:I48").Value
z = Range("E2:E48").Value
B = "Total ISU Days: "
'The the cells are empty then subtract. This is not what I wanted to do but I can't think of extracting strings from variants.
If IsEmpty(Range("D2:D48").Value) = True Then
a = y - z
End If
Range("N2:N48").Value = a
Range("M2:M48").Value = B
End Sub
x = Range("D2:D48").Value
y = Range("I2:I48").Value
z = Range("E2:E48").Value
A Variant contains metadata about its subtype. In this case, x, y, and z are all arrays of variants.
a = y - z
The right-hand side of this expression simply cannot be evaluated, because {array1} - {array2} means nothing: operators (arithmetic or logical) work off values, not array of values.
What is a supposed to be? It's declared As Integer, so its value is capped at 32,767 (should probably be a Long). If you mean to add up all the values in y and subtract that total from the sum of all values in z, then you need to be more explicit about how you do that - you could use Application[.WorksheetFunction].Sum to add things up:
sumOfY = Application.Sum(Range("I2:I48"))
sumOfZ = Application.Sum(Range("E2:E48"))
a = sumOfY - sumOfZ
And then...
Range("N2:N48").Value = a
That will put the value of a in every single cell in the N2:N48 range - is that really what you mean to do?
Or maybe you meant to do this instead?
Range("N2:N48").Formula = "=IF(D2="""",I2-E2,0)"
That would make each cell in N2:N48 calculate the difference between I and E for each row where D is empty... and there's not really any need for any VBA code to do this.
Let's simplify a bit the task and say that the idea is to substract the values in Range("C1:C6") from the corresponding values in the left - Range("B1:B6"). Then write the corresponding results in column E:
Of course, this would be done only in case that all values in column A are empty. This is one way to do it:
Sub TestMe()
Dim checkNotEmpty As Boolean: checkNotEmpty = False
Dim substractFrom As Range: Set substractFrom = Worksheets(1).Range("B1:B6")
Dim substractTo As Range: Set substractTo = Worksheets(1).Range("C1:C6")
Dim MyCell As Range
Dim result() As Variant
ReDim result(substractFrom.Cells.Count - 1)
Dim areCellsEmpty As Boolean
For Each MyCell In substractFrom
If Len(MyCell) > 0 Then checkNotEmpty = True
Next
Dim i As Long
For i = LBound(result) + 1 To UBound(result) + 1
result(i - 1) = substractFrom.Cells(i) - substractTo.Cells(i)
Next
Worksheets(1).Range("E1").Resize(UBound(result) + 1) = Application.Transpose(result)
End Sub
The code could be improved further, saving all ranges to an Array, but it works quite ok so far.
The part with the +1 and -1 in the For-loop is needed as a workaround:
For i = LBound(result) + 1 To UBound(result) + 1
result(i - 1) = substractFrom.Cells(i) - substractTo.Cells(i)
Next
because the arrays start from index 0, but the Cells in a range start with row 1.
Worksheets(1).Range("E1").Resize(UBound(result) + 1) = Application.Transpose(result) is needed, to write the values of the result array to the column E, without defining the length of the range in E.
While trying to use COUNTIF and SUMIF with a table that regularly has long comments, I kept getting a #VALUE error. A little bit of research said that the error could be due to the criteria string topping the 256 character point.
Any suggestions on how to get around this? I've worked out a solution I'll be posting as an Answer, but I'd like to see if anyone else has a Better Way.
I ended up writing a pair of UDFs in VB to get around the issue. There's still a character limit, but now it's 2^32, rather than 2^8.
The COUNTIF variation was pretty straightforward...
Function COUNTIFLONG(rng As Range, crt As String, ExactMatch As Boolean)
Dim Cell As Range
Dim x As Integer
x = 0
For Each Cell In rng
If IsNull(Cell.Value) Then GoTo CellCont
If ExactMatch Then
If Cell.Value = crt Then
x = x + 1
End If
Else
If (InStr(Cell.Value, crt) > 0) Then
x = x + 1
End If
End If
CellCont:
Next Cell
COUNTIFLONG = x
End Function
The SUMIF variation was a bit more tricky to get it to be flexible enough for regular use.
Function SUMIFLONG(rngCrt As Range, crt As String, rngSum As Range, ExactMatch As Boolean)
Dim Cell As Range
Dim x As Integer
Dim CrtRows As Integer, CrtCols As Integer, SumRows As Integer, SumCols As Integer
Dim RowOffset As Integer, ColOffset As Integer
Dim SumDir As String
CrtRows = rngCrt.Rows.Count
CrtCols = rngCrt.Columns.Count
SumRows = rngSum.Rows.Count
SumCols = rngSum.Columns.Count
crt = Trim(crt)
x = 0
If (CrtRows <> SumRows) Or (CrtCols <> SumCols) Then
Debug.Print ("Arrays are not the same size. Please review the formula.")
Exit Function
End If
If (CrtRows <> 1) And (CrtCols <> 1) And (SumRows <> 1) And (SumCols <> 1) Then
Debug.Print ("Please restrict arrays to one column or row at a time.")
Exit Function
End If
'Detects the offset of the Sum row/column from the Criteria row/column
RowOffset = rngSum.Row - rngCrt.Row
ColOffset = rngSum.Column - rngCrt.Column
For Each Cell In rngCrt
'Ignores Null cells or rows where the Sum column's value is not a number.
If IsNull(Cell.Value) Or (Not IsNumeric(Cell.Offset(RowOffset, ColOffset).Value)) Then
GoTo CellCont
End If
'Adds Sum Column's value to the running total.
'If an Exact Match is not requested, will detect whether Criteria is present in target cell.
If ExactMatch Then
If Cell.Value = crt Then
x = x + Cell.Offset(RowOffset, ColOffset).Value
End If
Else
If (InStr(Cell.Value, crt) > 0) Then
x = x + Cell.Offset(RowOffset, ColOffset).Value
End If
End If
CellCont:
Next Cell
SUMIFLONG = x
End Function
As I said, I'd like to see if anyone had better Ideas of how to accomplish this, but I hope this helps!
Without sample data any suggestion is going to involve some guesswork but it sounds like your search criteria could be chopped down to unique pieces less than the 255 character limit and wrapped in wildcards.
=COUNTIF(A:A, "*"&C2&"*")
Click for full size image
I’m using a userform with 12 listboxes (numbered 2-13). Each list box could contain 0-8 items assigned by user from main listbox1. I run the following code to output the content of each list box (12 boxes) to sheet “Tray” when a button is pressed.
Each listbox is then output into corresponding columns of each tray from columns B-M. Listbox2 fills column 1 of each tray and so on. A maximum of 4 trays can be filled. The code checks the 1st well of each tray and if it contains a value it assumes the tray is full & begins filling the next tray.
Problem: If the first tray contains a blank column(listbox) and the second tray contains values in the same listbox, the code will fill blank column of the frist tray with values that should be in the second tray. Please see pictures below and updated code below:
Listboxes 2,3 and 4 for Tray 1 (note listbox3 is empty)
Listboxes 2,3 and 4 for tray 2 (note listbox3 has data)
Code ran two times: Listbox3 from tray2 appears in tray1 (erroneously!!!)
Expected output:
Sub Worklist()
'
Dim Var, VarName As Variant
Dim i, DblDashPos, FirstPeriodPos, lngColNum, lngRowNum As Long
Dim item As ListBox
Const cstrNames As String = "Listbox2,Listbox3,Listbox4,Listbox5,Listbox6,Listbox7,Listbox8,Listbox9,Listbox10,Listbox11,Listbox12,Listbox13"
Application.ScreenUpdating = False
lngColNum = 2
For Each VarName In Split(cstrNames, ",")
If UserForm2.Controls(VarName).ListIndex <> -1 Then 'if listbox is not blank
If Sheets("Tray").Cells(4, lngColNum).Value = 0 Then
'checks if value in row 3 column "lngColNum" is empty
lngRowNum = 4
ThisWorkbook.Sheets("Tray").Range("C2").Value = UserForm2.TextBox1.Value
ElseIf Sheets("Tray").Cells(15, lngColNum).Value = 0 Then 'checks if value in row 14 column "lngColNum" is empty
lngRowNum = 15
ThisWorkbook.Sheets("Tray").Range("C13").Value = UserForm2.TextBox1.Value
ElseIf Sheets("Tray").Cells(26, lngColNum).Value = 0 Then 'checks if value in row 14 column "lngColNum" is empty
lngRowNum = 26
ThisWorkbook.Sheets("Tray").Range("C24").Value = UserForm2.TextBox1.Value
Else 'otherwise assumes tray starts in row 5, column "lngColNum"
lngRowNum = 37
ThisWorkbook.Sheets("Tray").Range("C35").Value = UserForm2.TextBox1.Value
End If
For i = 0 To UserForm2.Controls(VarName).ListCount - 1
Var = UserForm2.Controls(VarName).List(i)
DblDashPos = InStr(1, Var, "--")
FirstPeriodPos = InStr(1, Var, ".")
Sheets("Tray").Select
ActiveSheet.Cells(lngRowNum, lngColNum) = Left(Var, DblDashPos - 1) & Right(Var, Len(Var) - FirstPeriodPos + 1)
lngRowNum = lngRowNum + 1
Next i
End If
lngColNum = lngColNum + 1
Next
Application.ScreenUpdating = True
End Sub
Thank you very much!
The problem is that you're only testing the column that corresponds to the ListBox to see if the cell is empty. If you want to test that all of the columns in a "tray" are empty, you need to test once for the entire sheet. Something like this (untested because I'm too lazy to rebuild your form):
Private Function FindFirstUnusedRow(sheet As Worksheet) As Long
Dim testColumn As Long, testRow As Long
Dim used As Boolean
For testRow = 4 To 37 Step 11
used = False
For testColumn = 2 To 13
If IsEmpty(sheet.Cells(testRow, testColumn)) = False Then
used = True
Exit For
End If
Next testColumn
If used = False Then
FindFirstUnusedRow = testRow
Exit For
End If
Next testRow
End Function
Then in your code, call it before your loop:
Sub Worklist()
Dim var As Variant
Dim i As Long, dashPos As Long, periodPos As Long, colNum As Long
Dim rowNum As Long, Dim sheet As Worksheet
Application.ScreenUpdating = False
Set sheet = ThisWorkbook.Sheets("Tray")
rowNum = FindFirstUnusedRow(sheet)
If rowNum = 0 Then
Debug.Print "All trays full."
Exit Sub
End If
Dim current As ListBox
For colNum = 2 To 13
Set current = UserForm2.Controls("Listbox" & colNum)
If current.ListIndex <> -1 Then 'if listbox is not blank
sheet.Cells(rowNum - 2, colNum).Value = UserForm2.TextBox1.Value
For i = 0 To current.ListCount - 1
var = current.List(i)
dashPos = InStr(1, var, "--")
periodPos = InStr(1, var, ".")
sheet.Cells(rowNum + i, colNum) = Left$(var, dashPos - 1) & _
Right$(var, Len(var) - periodPos + 1)
Next i
End If
Next colNum
Application.ScreenUpdating = True
End Sub
A couple other notes: You can ditch the Sheets("Tray").Select line entirely - you never use the selection object. Same thing with the mixed references to ActiveSheet and ThisWorkbook.Sheets("Tray"). Grab a reference and use it.
Also, these lines don't do what you think they do:
Dim Var, VarName As Variant
Dim i, DblDashPos, FirstPeriodPos, lngColNum, lngRowNum As Long
Of all the variables you declare, everything is a Variant except lngRowNum. If you want to combine declarations on one line like that, you still need to specify a type for each variable, or they'll default to Variant. See the example code above.
I'm building an Excel program at work so that collegues can view their upsells. What i'm stuck on is the population of the listbox.
When I populate the listbox it returns all rows. What I need it too return though is all rows where the name in the E column matches with the one contained in the public variable.
I searched all over to try and find a solution but have not had any luck.
Any help would be greatly appreciated as this is starting to bug me now.
Public Sub UserForm_Initialize()
var_associate = "Kirsty"
Dim var_nextline As Integer
var_nextline = 1
x = "a"
Do While x <> ""
x = Cells(var_nextline, 2)
If x <> var_associate Then
var_nextline = var_nextline + 1
Else
Me.lsb_upsell.AddItem(var_nextline, 2).Value
var_nextline = var_nextline + 1
End If
Loop
End Sub
x = Cells(var_nextline, 2)
should give an error, as the right-hand side returns the cell object, not the value contained in the cell, and assignment of objects must be done by using Set. Anyway, it is not what you want to have. Try
x = Cells(var_nextline, 2).Value2
Remark: You could improve your code:
Public Sub UserForm_Initialize()
Dim var_associate As String
var_associate = "Kirsty"
Dim var_nextline As Integer
var_nextline = 1
Dim x As String
Do
x = Cells(var_nextline, 2).Value2
If x = "" Then Exit Loop
If x = var_associate Then
Me.lsb_upsell.AddItem(x).Value
End If
var_nextline = var_nextline + 1
Loop
End Sub
Second remark: Where is Cells initialized (e.g. with Set Cells = ActiveSheet.Cells)? Add Option Explicit at the top of your file in order to get error messages for undeclared variables. Do you mean something like
ActiveSheet.Cells(var_nextline, 2).Value
?
I'm trying to generate words in Column B from a list of given words in Column A.
Right now my code in Excel VBA does this:
Function GetText()
Dim GivenWords
GivenWords = Sheets(1).Range(Sheets(1).[a1], Sheets(1).[a20])
GetText = A(Application.RandBetween(1, UBound(A)), 1)
End Function
This generates a word from the list I have provided in A1:A20, but I don't want any duplicates.
GetText() will be run 15 times in Column B from B1:B15.
How can I check for any duplicates in Column B, or more efficiently, remove the words temporarily from the list once it has been used?
For example,
Select Range A1:A20
Select one value randomly (e.g A5)
A5 is in Column B1
Select Range A1:A4 and A6:A20
Select one value randomly (e.g A7)
A7 is in Column B2
Repeat, etc.
This was trickier than I thought. The formula should be used as a vertical array eg. select the cells where you want the output, press f2 type =gettext(A1:A20) and press ctrl+shift+enter
This means that you can select where your input words are in the worksheet, and the output can be upto as long as that list of inputs, at which point you'll start getting #N/A errors.
Function GetText(GivenWords as range)
Dim item As Variant
Dim list As New Collection
Dim Aoutput() As Variant
Dim tempIndex As Integer
Dim x As Integer
ReDim Aoutput(GivenWords.Count - 1) As Variant
For Each item In GivenWords
list.Add (item.Value)
Next
For x = 0 To GivenWords.Count - 1
tempIndex = Int(Rnd() * list.Count + 1)
Aoutput(x) = list(tempIndex)
list.Remove tempIndex
Next
GetText = Application.WorksheetFunction.Transpose(Aoutput())
End Function
Here's how I would do it, using 2 extra columns, and no VBA code...
A B C D
List of words Rand Rank 15 Words
Apple =RAND() =RANK(B2,$B$2:$B$21) =INDEX($A$2:$A$21,MATCH(ROW()-1,$C$2:$C$21,0))
copy B2 and C2 down as far as the list, and drag D down for however many words you want.
Copy the word list somewhere, as every time you change something on the sheet (or recalculate), you will get a new list of words
Using VBA:
Sub GetWords()
Dim Words
Dim Used(20) As Boolean
Dim NumChosen As Integer
Dim RandWord As Integer
Words = [A1:A20]
NumChosen = 0
While NumChosen < 15
RandWord = Int(Rnd * 20) + 1
If Not Used(RandWord) Then
NumChosen = NumChosen + 1
Used(RandWord) = True
Cells(NumChosen, 2) = Words(RandWord, 1)
End If
Wend
End Sub
Here is the code. I am deleting the cell after using it. Please make a backup of your data before using this as it will delete the cell contents (it will not save automatically...but just in case). You need to run the 'main' sub to get the output.
Sub main()
Dim i As Integer
'as you have put 15 in your question, i am using 15 here. Change it as per your need.
For i = 15 To 1 Step -1
'putting the value of the function in column b (upwards)
Sheets(1).Cells(i, 2).Value = GetText(i)
Next
End Sub
Function GetText(noofrows As Integer)
'if noofrows is 1, the rand function wont work
If noofrows > 1 Then
Dim GivenWords
Dim rowused As Integer
GivenWords = Sheets(1).Range(Sheets(1).Range("A1"), Sheets(1).Range("A" & noofrows))
'getting the randbetween value to a variable bcause after taking the value, we can delete the cell.
rowused = (Application.RandBetween(1, UBound(GivenWords)))
GetText = Sheets(1).Range("A" & rowused)
Application.DisplayAlerts = False
'deleting the cell as we have used it and the function should not use it again
Sheets(1).Cells(rowused, 1).Delete (xlUp)
Application.DisplayAlerts = True
Else
'if noofrows is 1, there is only one value left. so we just use it.
GetText = Sheets(1).Range("A1").Value
Sheets(1).Cells(1, 1).Delete (xlUp)
End If
End Function
Hope this helps.