i have faced with issue while merging some dynamic ranges through VBA.
Once it is standard range like Range("A3:E4"), all is fine and i have 2 lines in values of the range.
screen from add watch
But once i want to merge different ranges like Range("A3:E3,A4:E4") i am receiving only value of the first range. Who knows how it can be fixed, and how can i correctly merge different ranges in VBA, to use their values later?
Thanks in advance
Each Range has a property named Areas which contain the sub-tables of cells.
Consider the code below
Dim r As Range
Set r = Union(Range("F2:F6"), Range("H2:H6"))
Dim a As Range
For Each a In r.Areas
Debug.Print a.Address
Next
which prints out
$F$2:$F$6
$H$2:$H$6
So each area would be used to define it own array of values
Dim a_vals as Variant, b_vals as Variant
a_vals = r.Areas(1).Value2
b_vals = r.Areas(2).Value2
I'm not an expert working with arrays, but these two methods have helped me working with ranges and merging them into 1D arrays separated by a character
Method 1: Define separate ranges and merge their content into 1D array
Public Sub MergeTwoRangesIntoArray()
' Get range 1 values into 1d array
Dim range1Values As Variant
range1Values = WorksheetFunction.Transpose(Application.Index(Range("A1:A10"), 0, 1))
' Get range 2 values into 1d array
Dim range2Values As Variant
range2Values = WorksheetFunction.Transpose(Application.Index(Range("B1:B10"), 0, 1))
' Define and redimension an array to hold the concatenated area and category values
Dim mergedRangeValues() As Variant
ReDim mergedRangeValues(1 To UBound(range1Values))
' Concatenate the area and category values and store them in an array
Dim counter As Long
For counter = 1 To UBound(range1Values)
mergedRangeValues(counter) = range1Values(counter) & "|" & range2Values(counter)
Next counter
Stop
End Sub
Method 2: Define multi area range and merge each areas' content into 1D array
Public Sub MergeTwoAreasIntoArray()
Dim multiRange As Range
Set multiRange = Range("A1:A10,B1:B10,C1:C11")
Dim totalAreas As Long
totalAreas = multiRange.Areas.Count
Dim rangeValues() As Variant
ReDim rangeValues(1 To totalAreas)
Dim areaCounter As Long
For areaCounter = 1 To totalAreas
' Get range 1 values into 1d array
rangeValues(areaCounter) = WorksheetFunction.Transpose(Application.Index(multiRange.Areas(areaCounter), 0, 1))
Next areaCounter
' Get the upper bound of the range values (first range)
Dim totalRangeValues As Long
totalRangeValues = UBound(rangeValues(1))
Dim resultArray As Variant
ReDim resultArray(1 To totalRangeValues)
Dim itemCounter As Long
For itemCounter = 1 To totalRangeValues
Dim rangeCounter As Long
For rangeCounter = 1 To totalAreas
resultArray(itemCounter) = resultArray(itemCounter) & "|" & rangeValues(rangeCounter)(itemCounter)
Next rangeCounter
Next itemCounter
End Sub
Related
I'm new to the VBA programming language so I'm asking for some help.
I'm trying to automatize building a waterfall chart in Excel using VBA. Usually I did everything manually and it often took quite a while when data changed. So I decided to use VBA to fasten the process.
To create a waterfall chart, I need to create additional series of data. I'm trying to do it by using arrays and loops.
For one, I need to create an array which consists of absolute values of the initial array (range). But I run into an error "Subscript out of range" and can't figure out what the problem is. In Python, which I know better, I guess, there wouldn't be such a problem.
Here's my code:
Sub CreateWaterfall()
'*************************************************************************
Dim i As Integer
'*************************************************************************
' Turn a range into an array
Dim FigureArrayLength As Integer
FigureArrayLength = Range("B3", Range("B3").End(xlToRight)).Count
Dim FiguresArr() As Variant
ReDim FiguresArr(FigureArrayLength)
FiguresArr = Range("B3", Range("B3").End(xlToRight))
'*************************************************************************
' Build another array based on FiguresArr, but making all the values positive
Dim AuxiliaryFiguresArr() As Variant
ReDim AuxiliaryFiguresArr(FigureArrayLength)
For i = 1 To FigureArrayLength
AuxiliaryFiguresArr(i) = Abs(FiguresArr(i))
Next i
End Sub
What Excel doesn't like is this line, which gets highlighted in yellow when I press the 'Debug' button:
AuxiliaryFiguresArr(i) = Abs(FiguresArr(i))
What could the problem be?
Absolute Values of a Row to an Array
Sub ArrAbsRowTEST()
' Reference the worksheet ('ws').
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the one-row range ('rrg') (a pretty risky way).
Dim rrg As Range: Set rrg = ws.Range("B3", ws.Range("B3").End(xlToRight))
' Using the 'ArrAbsRow' function (on the range),
' write the converted values to an array ('Arr').
Dim Arr() As Variant: Arr = ArrAbsRow(rrg)
' Continue, e.g.:
Debug.Print "The array contains the following numbers:"
Debug.Print Join(Arr, vbLf)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the absolute values of the values from the first row
' of a range ('rrg') in a 1D one-based array.
' Remarks: It is assumed that the first row of the range
' contains numbers only.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrAbsRow( _
ByVal rrg As Range) _
As Variant
' Write the values from the first row of the range
' to a 2D one-based one-row array ('rData').
Dim rData() As Variant
Dim cCount As Long
With rrg.Rows(1)
cCount = .Columns.Count
If cCount = 1 Then ' one cell
ReDim rData(1 To 1, 1 To 1): rData(1, 1) = .Value
Else ' multiple cells
rData = .Value
End If
End With
' Write the absolute values of the values from the 2D array
' to the resulting 1D one-based array ('Arr').
Dim Arr() As Variant: ReDim Arr(1 To cCount)
Dim c As Long
For c = 1 To cCount
Arr(c) = Abs(rData(1, c))
Next c
' Assign the 1D array to the result.
ArrAbsRow = Arr
End Function
I tested the below and returned to this page and then saw the solution from VBasic2008; so thought I'd add my answer too.
When I first did this, I assumed that the range derived array would be one dimensional too. I realised my mistake, when I added the array as a watch and was then able to see its dimensions.
Option Explicit
Private Sub CreateWaterfall()
'*************************************************************************
Dim i As Integer
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("Sheet1")
'*************************************************************************
' Turn a range into an array
Dim FiguresArr As Variant
FiguresArr = WS.Range("B3", WS.Range("B3").End(xlToRight))
'*************************************************************************
' Build another array based on FiguresArr, but making all the values positive
ReDim AuxiliaryFiguresArr(0, 0) As Variant
AuxiliaryFiguresArr(0, 0) = 0
For i = 1 To UBound(FiguresArr, 2)
Call AddEntry(AuxiliaryFiguresArr, Abs(FiguresArr(1, i)))
Next i
End Sub
The procedure below is called by the code above
Public Sub AddEntry(aList As Variant, aEntry As Variant)
'
' build array for later copy onto sheet
'
Dim i%
Dim aEntry2 As Variant
If VarType(aEntry) = vbDouble Or VarType(aEntry) = vbInteger Then
aEntry2 = Array(aEntry)
Else
aEntry2 = aEntry
End If
If aList(0, 0) <> 0 Then
ReDim Preserve aList(0 To UBound(aEntry2), 0 To UBound(aList, 2) + 1)
End If
For i = 0 To UBound(aEntry2)
aList(i, UBound(aList, 2)) = aEntry2(i)
Next
End Sub
Using VBA, I would like to AND across each row in a 2D array and star the result in separate 1D array without ANDing a single pair the ANDing the result with the next item in that row.
FYI This is my first time using 2D arrays so sorry if there is an obvious solution.
For example if the data in my sheet looked like this (the actual range is much larger):
I would like to do the equlavant of an excel formula: =AND(B2:D2) then =AND(B3:D3), etc...
I have code that sets everything up but I don't know how to proceed except to loop across each element of a row, store the result then loop across the next, etc, etc. I'm hoping the there is a much better (more efficient) way to proceed.
Here is my code so far
Sub Exceptions()
' Setup worksheet
Dim wks As Worksheet
Set wks = cnTest
' Find last row of range
Dim LastRow As Long
LastRow = Find_LastRow(wks) 'Functionthat returns last row
' load range into array
Dim MyArray As Variant
MyArray = wks.Range("B2:D8")
' Setup 1D Result array
Dim Results As Variant
Results = wks.Range("A2:A8")
Dim i As Long
For i = 1 To LastRow
' Perform AND function on each row of the array
' then place result in 1D array (Results())
' If this were a formul: =AND(B2:D2)
'
' Is there way to "AND" across a row in and array or
' must I "AND" MyArray(1,1) with MyArray(1,2) then AND
' that result with MyArray(1,3)
Next i
End Sub
Thank you
Try this.
Sub Exceptions()
' Setup worksheet
' load range into array
Dim MyArray As Variant
MyArray = ActiveSheet.Range("B2:D8")
' Setup 1D Result array
Dim Results As Variant
Results = ActiveSheet.Range("A2:A8")
Dim i As Long
Dim X As Long
For i = 1 To UBound(MyArray, 1)
Results(i, 1) = "True"
For X = 1 To UBound(MyArray, 2)
If MyArray(i, X) = False Then
Results(i, 1) = "False"
Exit For
End If
Next X
Next i
End Sub
Try,
Sub test()
Dim vR()
Dim rngDB As Range, rng As Range
Dim i As Long, r As Long
Set rngDB = Range("b2:b8")
r = rngDB.Rows.Count
ReDim vR(1 To r)
For Each rng In rngDB
i = i + 1
vR(i) = WorksheetFunction.And(rng.Resize(1, 3))
Next rng
Range("a2").Resize(r) = WorksheetFunction.Transpose(vR)
End Sub
In the formula bar, type:
=IF(-PRODUCT(IF(A1,-1,0),IF(C1,-1,0)),TRUE,FALSE)
(if the data is in columns A and C), and drag down.
Because, as everyone knows, A AND B = AB if A and B are Boolean variables (and watch the minus in front of the PRODUCT).
I am trying to resize a dynamic array (Sub rangearray) with new values after checking if any values in the original array > 590.
The array is one dimensional column with a range of figures as shown below just 1 column and multiples rows.
I have tried a variety of possible solutions and none seems to work. I can observe on the Locals window even though this is a one dimensional array it appears a two dimensional with (1 to 5, 1 to 1) and I did manage to obtain 620 and 630 on the message box and I tried to replicate this code for the worksheet but I constantly got subscript out of range.
I would appreciate if someone could please let me know what I need to do to resize the array (copied to sheet) with only the new values not the previous values and also explain the dimension of one dimension and multiples dimensions array.
I do know that with Redim you can only change the second dimension and that is where I am a bit confused does the one dimension below have two dimension or one its seems like two otherwise it would only have one dimension which should make resizing easier.
Solution that works but just message box not worksheet
For i = 1 To 5
For j = 1 To 1
If arr(i, j) > 590 Then
MsgBox arr(i, j)
End If
Next j
Next i
Dataset
590
590
590
620
630
Array that does not work below paste value from resized array to worksheet
Sub rangearray()
Dim arr() As Variant
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim i As Variant
Dim ws2 As Workbook
Set ws2 = Workbooks("PRA.XLSM")
Set ws = Workbooks("PRA.XLSM").Worksheets("Rec")
Set ws1 = Workbooks("PRA.XLSM").Worksheets("CPT")
arr() = ws.Range("a4:a15").Value
For Each i In arr
If i > 590 Then
ReDim arr(i)
arr(i) = i
End If
Next i
ws1.Range("A4:A15").Value = WorksheetFunction.Transpose(arr)
End Sub
Your array to be processed is a 2D array type. You do not need (only) an 1D array to accomplish what you want, but if this is your wish, it can be done using another array (1D in this case, but it could be 2D, too).
Redim can be used for any Dim array without specifying the dimensions. Redim Preserve can be used only for the second dimension and it means changing the second one, but preserving values.
Please, use this code to accomplish what (I understood) you wanted:
Dim arr() As Variant, ws As Worksheet, ws1 As Worksheet, i As Long
Dim arrF As Variant, k As Long
Set ws = Workbooks("PRA.XLSM").Worksheets("Rec")
Set ws1 = Workbooks("PRA.XLSM").Worksheets("CPT")
arr() = ws.Range("a4:a15").Value
ReDim arrF(UBound(arr))
For i = 1 To UBound(arr)
If arr(i, 1) < 590 Then
arrF(k) = arr(i, 1): k = k + 1
End If
Next i
ReDim Preserve arrF(k - 1)
ws1.Range("A4").Resize(UBound(arrF) + 1, 1).Value = WorksheetFunction.Transpose(arrF)
End Sub
What I think it is good to know, you could also use a 2D (new) array. In such a case you had to Redim in this way:
ReDim arrF(1 To 1, 1 To UBound(arr))' the rows and columns are reversed, only to allow Redim Preserve (for the last dimension), after the loop where it was load
It should be load (like a 2D array) in this way:
arrF(1, k) = arr(i, 1)
And Resize should be adapted to a 2D array:
ws1.Range("A4").Resize(UBound(arrF, 2), 1).Value
Transpose is maintained but only to transpose rows to columns...
Declare a new variable named value (1-dimensional array), after check condition, use redim preserve combination with worksheetfunction.transpose will work:
Here's sample code:
Sub rangearray()
Dim value()
ReDim value(1 To 15 - 4 + 1)
arr = Range("a4:a15").value
Dim i As Integer
i = 1
For Each cell In arr
If cell > 590 Then
value(i) = cell
i = i + 1
End If
Next
ReDim Preserve value(1 To i - 1)
Range("A4:A15").Clear 'clear contents before write new values
Range("A4:A15").Resize(i - 1, 1).value = WorksheetFunction.Transpose(value)
End Sub
Try,
Sub rangearray()
Dim arr() As Variant
Dim a() As Variant
Dim ws As Worksheet
Dim ws1 As Worksheet
Dim i As Long
Dim ws2 As Workbook
Dim n As Long
Set ws2 = Workbooks("PRA.XLSM")
Set ws = Workbooks("PRA.XLSM").Worksheets("Rec")
Set ws1 = Workbooks("PRA.XLSM").Worksheets("CPT")
arr() = ws.Range("a4:a15").Value
For i = 1 To UBound(arr, 1)
If arr(i, 1) > 590 Then
n = n + 1
ReDim Preserve a(1 To n)
a(n) = i
'a(n) = i + 3 'If you need the cell's row number,
End If
Next i
ws1.Range("A4").Resize(n) = WorksheetFunction.Transpose(a)
End Sub
First of all when you copy the values of a a range (multi-cell) into a Variant, you will always get a two-dimensional array. For example
Dim arr As Variant
arr = Range("A1:A5")
means that arr is a two dimensional array similar to arr(1 to 5, 1 to 1) (i.e. 5 rows and 1 column)
If you want to get a one-dimensional array you can use the Transpose worksheet function
Dim arr as Variant
arr = WorksheetFunction.Transpose(Range("A1:A5"))
Now it is like arr(1 to 5)
I am confused as to what you're doing in the loop. For example when you find a value of i > 590 (e.g. 600) you are re-dimensioning the array to 600 elements. Is that what you want? Furthermore, you are not perserving any values. For each i in arr gives i values of the elements of your arry (not the index), so doing something like arr(i) = i is assining the value of i to the ith element (is this what you're trying to achieve?)
I get the impression, all you want is to change values of those elements > 590 and for that you do not need to Redim: You simply change the value.
If you can explain exactly what you're trying to achieve, then I (or someone else) can help you further.
Edit (Answer):
Here are two of many ways you can achieve what you want:
The simplest way is to use the Filter() worksheet function. In your destination range enter the array formula
=FILTER(Rec!$A$4:$A$15,Rec!$A$4:$A$15>590)
Build an array to store the filtered values (I guess this is the approach you prefer)
Sub rangearray()
Dim vInput As Variant
Dim arrOutput() As Variant
Dim v As Variant
Dim lOutElems As Long: lOutElems = 0
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbooks("PRA.XLSM")
Dim ws As Worksheet: Set ws = wb.Worksheets("Rec")
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("CPT")
vInput = ws.Range(ws.Range("A4"), ws.Range("A" & Rows.count).End(xlUp)).Value
'vInput = ws.Range("a4:a15").Value ' or hardcoded
For Each v In vInput
If v > 590 Then
lOutElems = lOutElems + 1
ReDim Preserve arrOutput(1 To lOutElems)
arrOutput(lOutElems) = v
End If
Next v
ws1.Range("A4").Resize(lOutElems, 1).Value = WorksheetFunction.Transpose(arrOutput)
End Sub
Another approach is to use autofilter (in excel sheet or in VBA). You could also use the Filter() worksheet function in VBA. The choice is yours.
You can read single column values into a 1D array using WorksheetFunction.Transpose twice. For example, you have a column with data starting in A1 cell. Then you can fill the 1D array as follows:
Sub ch()
Dim arr()
Dim nRows As Integer
nRows = Sheet1.Range("A1").End(xlDown).Row
ReDim arr(1 To nRows)
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Sheet1.Range("A1").Resize(nRows, 1)))
End Sub
Return dynamic array from function VBA got me part of the way on this problem. I realized I should know size prior to invoking the function.
Function GetHeadersFromRange(DataRange As Range, Size As Integer) As Variant
Dim Column As Integer
Dim Headers As Variant
ReDim Headers(0 To Size)
For Column = 1 To DataRange.Columns.Count
Headers(Column) = DataRange(1, Column).Value
Next
GetHeadersFromRange = Headers
End Function
Sub TestGetHeadersFromRange()
Application.DisplayAlerts = False
Set wb = ThisWorkbook
Set TestSheet = wb.Sheets.Add()
TestSheet.Range("A1").Value = "my_header"
TestSheet.Range("A2").Value = "val"
Dim DataRange As Range: Set DataRange = TestSheet.Range("A1:A2")
Dim Size As Integer: Size = DataRange.Columns.Count
Dim Result As Variant
' Gets type mismatch
Set Result = GetHeadersFromRange(DataRange, Size)
End Sub
Not entirely sure what to do here. I need to use this function in multiple places which is why it is a function in the first place.
Edit: Clarify problem
Set Result = GetHeadersFromRange(...) gets a type mismatch.
Header Function
Improvement
Your error occurs because you are using Set (used for objects)
on an array.
A more efficient (faster) way than looping through a range is looping
through an array.
When you copy a range to a variant (possibly array), if the range
contains one cell, the variant will contain one value only. But if
the range contains multiple cells, it will be an array, whose size is
returned with UBound. Therefore there is no need for a Size argument.
IsArray is used to determine if a variant is an array. In our case we can check if the number of columns (elements) is greater than 1 instead.
Option Explicit
Function GetHeadersFromRange(DataRange As Range) As Variant
Dim vntR As Variant ' Range Variant
Dim vntH As Variant ' Header Array
Dim Noe As Long ' Number of Elements
Dim j As Long ' Range Array Column Counter,
' Header Array Element Counter
With DataRange
' Calculate Number of Elements.
Noe = .Columns.Count
' Calculate Header Range.
' Copy Header Range to Range Variant.
vntR = .Resize(1, Noe)
' Note: Range Variant (vntR) is a 2D 1-based 1-row array only if
' DataRange contains more than one column. Otherwise it is
' a variant containing one value.
End With
'' Check if Range Variant is an array.
'If IsArray(vntR) Then
' Check if Number of Elements is greater than 1.
If Noe > 1 Then
' Resize 1D 0-based Header Array to number of columns (2) in Range
' Array minus 1 (0-based).
ReDim vntH(Noe - 1)
' Loop through columns of Range Array.
For j = 1 To Noe
' Write value at first row (1) and current column (j) of Range
' Array to current element (j-1) of Header Array.
vntH(j - 1) = vntR(1, j)
Next
Else
' Resize 1D 0-based Header Array to one element only (0).
ReDim vntH(0)
' Write Range Variant value to only element of Header Array.
vntH(0) = vntR
End If
GetHeadersFromRange = vntH
End Function
Sub TestGetHeadersFromRange()
Dim TestSheet As Worksheet ' Source Worksheet
Dim DataRange As Range ' Data Range
Dim Result As Variant ' Result Variant (possibly Array)
Dim i As Long ' Result Array Element Counter
' Add a new worksheet (Source Worksheet).
' Create a reference to the newly added Source Worksheet.
Set TestSheet = ThisWorkbook.Sheets.Add()
' In Source Worksheet
With TestSheet
' Add some values.
.Range("A1").Value = "my_header"
.Range("A2").Value = "val"
.Range("B1").Value = "my_header2"
.Range("B2").Value = "val2"
End With
' Test 1:
Debug.Print "Test1:"
' Create a reference to DataRange.
Set DataRange = TestSheet.Range("A1:A2")
' Write Data Range to 1D 0-based Result Array.
Result = GetHeadersFromRange(DataRange)
' Loop through elements of Result Array.
For i = 0 To UBound(Result)
' Write current element of Result Array to Immediate window.
Debug.Print Result(i)
Next
' Test 2:
Debug.Print "Test2:"
' Create a reference to DataRange.
Set DataRange = TestSheet.Range("A1:B2")
' Write Data Range to 1D 0-based Result Variant.
Result = GetHeadersFromRange(DataRange)
' Loop through elements of Result Array.
For i = 0 To UBound(Result)
' Write current element of Result Array to Immediate window.
Debug.Print Result(i)
Next
End Sub
I have an Excel sheet abc.xlsm" and I have values in "A1" to "A15" in this sheet. I want to copy till 10th row, and then store all the values in an array using VBA.
As mentioned in the comments, please be more specific in your questions: most questions should have at least some bit of code of what you have tried. At any rate this should work, with a couple extra notions:
Sub copy()
'Declaring an array - if you know the data type you can type is as well
Dim varray As Variant
'Declaring other variables - don't need to be separeted, just for clarity
Dim i As Long, iLenghtArray As Integer, rgData As Range, rgTarget As Range
'This is to dimension your array - you have tell VBA the lenght of it, or use REDIM
ilengtharray = 10
'Setting the range reference
Set rgData = Sheet1.Range("$A$1:$J$1")
'Then set the array = to the range you set above
varray = rgData
'Then you can interate over your array like so:
For i = 1 To UBound(varray, 2)
Debug.Print varray(1, i)
Next
'You can also directly past your array into a suitable range
'Setting destination range:
Set rgTarget = Sheet1.Range("$A$2:$J$2")
rgTarget = varray
End Sub