I tried the accepted answer of Loop through cells and add to a range with a little bit of variation, but my Range Arr was never appended.
When I tried to debug through it, it was only the first range. The Union never worked. Why is this?
Source code:
Public Function VisibleRows(InRange As Range) As Range
Dim R As Range
Dim Arr As Range
Dim RNdx As Integer
Dim Count As Integer
For RNdx = 1 To InRange.Rows.Count
Set R = InRange(RNdx)
If R.EntireRow.Hidden = False And R.Value2 <> "" Then
If Arr Is Nothing Then
Set Arr = R
Else
Set Arr = Union(Arr, R)
End If
End If
Next RNdx
VisibleRows = Arr
End Function
I can see a couple of problems with the code:
You're looping row by row, but the expression InRange(RNdx) takes the RNdx'th cell within the range - it goes horizontally first and then vertically. You probably want InRange.Cells(RNDx, 1)
Should be Set VisibleRows = Arr
Your function is returning a Range Object. Range objects are assigned to a variable with the word Set. You are not using this word. Try this, running TestMe().
Option Explicit
Public Sub TestMe()
VisibleRows(Range("A1:A10")).Select
End Sub
Public Function VisibleRows(InRange As Range) As Range
Dim R As Range
Dim Arr As Range
Dim RNdx As Integer
Dim Count As Integer
For RNdx = 1 To InRange.Rows.Count
Set R = InRange(RNdx)
If R.EntireRow.Hidden = False And R.Value2 <> "" Then
If Arr Is Nothing Then
Set Arr = R
Else
Set Arr = Union(Arr, R)
End If
End If
Next RNdx
Set VisibleRows = Arr
End Function
This is the sample result from it:
Related
I am trying to write a VBA function that takes a table with two columns as input. I want to return the elements in column 2 for which the corresponding row in column 1 is 3. Basically the equivalent of a where clause in SQL.
The logic of the code seems fine, however I get a type mismatch error. I declare the function As Variant and the array I want to return is As Variant as well.
Function FilterTable(tableName As String) As Variant
Dim table As range
Dim cell As range
Dim names As range
Dim i As Integer
Dim names_2(100) As Variant
Dim j As Integer
Dim test As String
i = 1
j = 1
Set table = ActiveSheet.range(tableName).Columns(1)
Set names = ActiveSheet.range(tableName).Columns(2)
For Each cell In table.Cells
If cell = 3 Then
names_2(i) = names.Cells(j, 1).Value
i = i + 1
End If
j = j + 1
Next
FilterTable = names_2
End Function
Why do I get a Type Mismatch error, and how can I fix it?
There are a few problems with your code but nothing that should cause a type mismatch unless you have worksheet errors (e.g. #N/A, #DIV/0!, etc) in your data.
You should be aware of what worksheet your table is on; don't rely on activesheet.
A 1-D array defaults as zero-based, not one-based.
You should remove the excess (empty) elements in your array after populating it. Use the Locals window or set a Watch on your array to see it populate and resize as you step through the function with F8.
Option Explicit
Sub main()
Dim n As Variant, i As Long
n = FilterTable("table1")
For i = LBound(n) To UBound(n)
Debug.Print n(i)
Next i
End Sub
Function FilterTable(tableName As String) As Variant
Dim table As Range, names As Range, cell As Range
Dim i As Long, j As Long
Dim names_2 As Variant
i = 0
j = 1
ReDim names_2(100)
Set table = Worksheets("Sheet3").Range(tableName).Columns(1)
Set names = Worksheets("Sheet3").Range(tableName).Columns(2)
For Each cell In table.Cells
If Not IsError(cell) Then
If cell = 3 Then
names_2(i) = names.Cells(j, 1).Value
i = i + 1
End If
End If
j = j + 1
Next cell
ReDim Preserve names_2(i - 1)
FilterTable = names_2
End Function
I have a worksheet with many duplicated Conditional Formatting instances.
I'm trying to write code to tidy/delete many of them.
I need to modify the Format Condition.
Any idea why the following doesn't work?
Sub UpdateCondition(ByRef bFirst As Boolean, rng As Range, f As FormatCondition, replacementFormula As String)
If bFirst Then
f.Modify f.Type, , replacementFormula
f.ModifyAppliesToRange rng
bFirst = False
Else
f.Delete
End If
End Sub
I get the following error:
Method 'ModifyAppliesToRange' of object 'FormatCondition' failed
This code works for many of my conditions. Only some of them trip up.
-- edit --
My calling code is as follows
Dim f As FormatCondition
Dim bFirst As Boolean
Dim i As Integer
Set rng = SomeRangeOnTheSheet
bFirst = True
For i = ActiveSheet.Range(Cells.Address).FormatConditions.Count To 1 Step -1
Set f = ws.Range(Cells.Address).FormatConditions(i)
If f.Formula1 = "..Some Formula.." Then
UpdateCondition bFirst, rng, f, replacementFormula
End If
Next
-- edit --
Function SomeRangeOnTheSheet() As Range
Dim cell1 As Range
Dim cell2 As Range
Set cell1 = Cells(Range("Roster").row, Range("StartDate").Column)
Set cell2 = Cells(Range("Roster").row + Range("Roster").Rows.Count - 1, Range("Roster").Column + Range("Roster").Columns.Count - 1)
Set RosterDataRange = Range(cell1, cell2)
End Function
I am trying to create a macro that reads data and does econometrics on the data. At this point I am trying to implement a latent variable MLE estimation.
The data can be of any length, depending on the user input. Suppose there is data in column O and column P. Ex-ante I have no idea how many rows of data exist.
I would like to first read how many data there are and then upload the data into my array variable before I can do any econometrics/statistics on it.
In this problem, the user has 25 data points for each variable. Some other user may enter different data with different number of data points.
In the code below, I am trying to read the variable "D" into an array. I first count the number of non-empty cells and then create an array of that size and try to read the value of the cells into the array. But I am getting a "type mismatch" error.
I've tried both "Variant" and "Array" types. Variant seems to be working but Array is not.
Sub SampleStats()
Dim Rng As String
Dim Var1(1 To 100) As Double
Dim Var2() As Double
Dim Var3 As Variant
Dim NumElements2 As Integer
Dim length2 As Integer
NumElements2 = WorksheetFunction.Count(Range("P:P"))
length2 = NumElements2+1
MsgBox NumElements2
ReDim Var2(1 To NumElements2)
Rng = "P2:P" & length2
MsgBox Rng
Var3 = Range(Rng).Value
MsgBox Var3(1,1)
Var2 = Range(Rng).Value
MsgBox Var2(1,1)
End Sub
My questions are:
Whats the best way to read data when you don't know how long the columns go?
What the best way to store data (Variant or Array or something else) when the final objective is doing some statistics?
First you get the Range with the column of data you want to pass into the array. Second you use the Application.Transpose function on the data and assign it to a Variant to create a 1-dimensional array from the Range.Value property.
If you just assign the range's Value directly to the Variant you will get a 2-dimensional array of N rows x 1 column. Sample code:
Option Explicit
Sub GetRangeToArray()
Dim ws As Worksheet
Dim rngData As Range
Dim varData As Variant
Dim lngCounter As Long
' get worksheet reference
Set ws = ThisWorkbook.Worksheets("Sheet1")
' get the column to analyse - example here is A2:A last row
' so using 1 in column reference to Cells collection
Set rngData = ws.Cells(2, 1).Resize(ws.Cells(ws.Rows.Count, 1).End(xlUp))
' convert range from 2d to 1d array
varData = Application.Transpose(rngData.Value)
' test array
For lngCounter = LBound(varData) To UBound(varData)
Debug.Print varData(lngCounter)
Next lngCounter
End Sub
sub createarraywithoutblanks()
creatary ary, Sheets("Table_Types"), "A":
alternative ary:
BuildArrayWithoutBlanks ary
end sub
Sub creatary(ary As Variant, sh As Worksheet, ltr As String)
Dim x, y, rng As range
ReDim ary(0)
Set rng = sh.range(ltr & "2:" & ltr & sh.range("A10000").End(xlUp).Row).SpecialCells(xlCellTypeVisible)
x = 0
For Each y In rng
ary(x) = y
x = x + 1
ReDim Preserve ary(x)
Next y
End Sub
Function Letter(oSheet As Worksheet, name As String, Optional num As Integer)
If num = 0 Then num = 1
Letter = Application.Match(name, oSheet.Rows(num), 0)
Letter = Split(Cells(, Letter).Address, "$")(1)
End Function
Sub alternative(ary As Variant)
Dim Array_2()
Dim Array_toRemove()
Dim dic As New Scripting.Dictionary
Dim arrItem, x As Long
For Each arrItem In ary
If Not dic.Exists(arrItem) Then
dic.Add arrItem, arrItem
Else
ReDim Preserve Array_toRemove(x)
Array_toRemove(x) = dic.Item(arrItem)
x = x + 1
End If
Next
'For Each arrItem In Array_toRemove
' dic.Remove (arrItem)
'Next arrItem
ary = dic.Keys
End Sub
Sub BuildArrayWithoutBlanks(ary As Variant)
Dim AryFromRange() As Variant, AryNoBlanks() As Variant
Dim Counter As Long, NoBlankSize As Long
'set references and initialize up-front
ReDim AryNoBlanks(0 To 0)
NoBlankSize = 0
'load the range into array
AryFromRange = ary
'loop through the array from the range, adding
'to the no-blank array as we go
For Counter = LBound(AryFromRange) To UBound(AryFromRange)
If AryFromRange(Counter) <> 0 Then
NoBlankSize = NoBlankSize + 1
AryNoBlanks(UBound(AryNoBlanks)) = AryFromRange(Counter)
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) + 1)
End If
Next Counter
'remove that pesky empty array field at the end
If UBound(AryNoBlanks) > 0 Then
ReDim Preserve AryNoBlanks(0 To UBound(AryNoBlanks) - 1)
End If
'debug for reference
ary = AryNoBlanks
End Sub
I'm trying to create a vba function in excel that sorts a column by cell color and then outputs the results to another location. What I have is currently giving me an error
Function SortColor(colorSearchRange As Range, colorToSearch As Range, outputRange As Range)
Dim colorValue As Integer
Dim coloredItems(150) As String
Dim index As Integer
colorValue = colorToSearch.Interior.ColorIndex
index = 0
Set cell = colorSearchRange
For Each cell In colorSearchRange
If cell.Interior.ColorIndex = colorValue Then
coloredItems(index) = cell.Value
index = index + 1
End If
Next cell
Range(outputRange & UBound(coloredItems) + 1) = WorksheetFunction.Transpose(coloredItems)
End Function
I'm new to visual basic. Any type of help would be greatly appreciated.
you need to use something like:
outputRange.Resize(index) = WorksheetFunction.Transpose(coloredItems)
also, you don't need Set cell = colorSearchRange, since cell is going to be set at each iteration of the For Each cell In colorSearchRange loop
finally your Function isn't returning anything so you can make it a Sub
all what above could result in what follows:
Sub SortColor(colorSearchRange As Range, colorToSearch As Range, outputRange As Range)
Dim colorValue As Long, index As Long
Dim coloredItems() As String
Dim cell As Range
ReDim coloredItems(1 To colorSearchRange.Rows.Count) As String 'dim your array to the maxiumum possible for the passed range
colorValue = colorToSearch.Interior.ColorIndex
For Each cell In colorSearchRange
If cell.Interior.ColorIndex = colorValue Then
index = index + 1
coloredItems(index) = cell.Value
End If
Next cell
outputRange.Resize(index) = WorksheetFunction.Transpose(coloredItems)
End Sub
So I am trying to create a function that will get all the unique values in a range, I'm new vba so I've made an attempt but it doesn't work (#VALUE). I eventually want each value in the array to be output one cell below it.
Here is the Code I wrote
Option Explicit
Function getUnique(dataSet As Range, Column As String)
Dim data() As String
Dim dataSize As Integer
Dim dictionary As Object
Dim i As Long
dataSize = dataSet.Rows.Count
Set dictionary = CreateObject("Scripting.Dictionary")
ReDim data(dataSize)
For i = 1 To UBound(data)
data(i) = dataSet(Column & i).Value
dictionary(data(i)) = 1
Next i
Dim v As Variant
For Each v In dictionary.Keys()
Debug.Print dictionary.Keys
Next v
Your code can work with a few changes, as indicated here:
Function getUnique(dataSet As Range) '<<< remove Column
Dim data() As String
Dim dataSize As Integer
Dim dictionary As Object
Dim i As Long
dataSize = dataSet.Rows.Count
Set dictionary = CreateObject("Scripting.Dictionary")
ReDim data(dataSize)
For i = 1 To UBound(data)
data(i) = dataSet.Cells(i, 1).Value '<<< using Cells
dictionary(data(i)) = 1
Next i
Dim v As Variant
For Each v In dictionary.Keys()
Debug.Print v '<<<
Next v
End Function
If, though, you are attempting to use this Function in a Worksheet cell then it won't work if you attempt to put values into other cells. User-Defined Functions don't work like that and you'll have to make it a Sub and run it on clicking a button, or some other event.