I am trying to copy a few non-contiguous columns (say Column A, Column C, Column E) into a dynamic array. However, it appears that only contiguous ranges were copied, leaving the non-contiguous ranges, when using the VBA Application.Union method.
I have tried copying contiguous columns (A, B, C, D, E), which worked as expected, but non-contiguous columns (A, C, E) doesn't.
Can anyone assist me on this? Thanks.
Sub TestFunction()
Dim TempArray() As Variant
Dim rngUnion As Range
With ThisWorkbook.Worksheets(2)
Set rngUnion = Application.Union(.Range("A1:A10"), .Range("C1:C10"), .Range("E1:E10"))
End With
TempArray = rngUnion
End Sub
Tim Williams already answered your question. I just wanted to demonstrate a cool way to create an array from multiple non-contiguous ranges. The key to this working is that all the ranges have 1 column and the same number of rows.
getArrayFromRanges takes the array of values from each range passed to it and converts it from a 2D array to an 1D array using Transpose. Each one of these 1D Temp arrays are added to the 1D Data array. Transpose is then used to convert the Data from an 1D Array od 1D arrays into a 2D array.
Sub TestFunction()
Dim Data
With Worksheets(2)
Data = getArrayFromRanges(.Range("A1:A10"), .Range("C1:C10"), .Range("E1:E10"))
.Range("A12").Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End With
End Sub
Function getArrayFromRanges(ParamArray Sources())
Dim Data, Temp, v
Dim x As Long
ReDim Data(UBound(Sources))
For Each v In Sources
Temp = Application.Transpose(v)
Data(x) = Temp
x = x + 1
Next
getArrayFromRanges = Application.Transpose(Data)
End Function
Sample Data from Contextures Excel Sample Data
You didn't mention what you are doing with the array, so I'm not sure if this will work for you. But, instead of the array, why not use rngUnion directly, and loop through its Areas collection as needed?
For example, this function:
Sub TestFunction2()
Dim rngUnion As Range
Dim area As Range
With ThisWorkbook.Worksheets(2)
Set rngUnion = Application.Union(.Range("A1:A10"), .Range("C1:C10"), .Range("E1:E10"))
End With
For Each area In rngUnion.Areas
Debug.Print area.Address
Next area
Set area = Nothing
Set rngUnion = Nothing
End Sub
Returns this output:
$A$1:$A$10
$C$1:$C$10
$E$1:$E$10
If you really do need the array, you could just use the same loop to add the individual Areas (i.e. Ranges) to the array.
Related
I have a large worksheet (~250K rows, 22 columns, ~40MB plain data) which has to transfer its content to an intranet API. Format does not matter. The problem is: When accessing the data like
Const ROWS = 250000
Const COLS = 22
Dim x As Long, y As Long
Dim myRange As Variant
Dim dummyString As String
Dim sb As New cStringBuilder
myRange = Range(Cells(1, 1), Cells(ROWS, COLS)).Value2
For x = 1 To ROWS
For y = 1 To COLS
dummyString = myRange(x, y) 'Runtime with only this line: 1.8s
sb.Append dummyString 'Runtime with this additional line 163s
Next
Next
I get a wonderful 2D array, but I am not able to collect the data efficiently for HTTP export.
An X/Y loop over the array and access myRange[x, y] has runtimes >1min. I was not able to find an array method which helps to get the imploded/encoded content of the 2D array.
My current workaround is missusing the clipboard (Workaround for Memory Leak when using large string) which works fast, but is a dirty workaround in my eyes AND has one major problem: The values I get are formatted, “.Value” and not “.Value2”, so I have to convert the data on server site again before usage, e.g. unformat currency cells to floats.
What could be another idea to deal with the data array?
My thoughts are that you create two string arrays A and B. A can be of size 1 to ROWS, B can be of size of 1 to COLUMNS. As you loop over each row in your myRange array, fill each element in B with each column's value in that row. After the final column for that row and before you move to the next row, join array B and assign to the row in A. With a loop of this size, only put necessary stuff inside the loop itself. At the end you would join A. You might need to use cstr() when assigning items to B.
Matschek (OP) was able to write the code based on the above, but for anyone else's benefit, the code itself might be something like:
Option Explicit
Private Sub concatenateArrayValues()
Const TOTAL_ROWS As Long = 250000
Const TOTAL_COLUMNS As Long = 22
Dim inputValues As Variant
inputValues = ThisWorkbook.Worksheets("Sheet1").Range("A1").Resize(TOTAL_ROWS, TOTAL_COLUMNS).Value2
' These are static string arrays, as OP's use case involved constants.
Dim outputArray(1 To TOTAL_ROWS) As String ' <- in other words, array A
Dim interimArray(1 To TOTAL_COLUMNS) As String ' <- in other words, array B
Dim rowIndex As Long
Dim columnIndex As Long
' We use constants below when specifying the loop's limits instead of Lbound() and Ubound()
' as OP's use case involved constants.
' If we were using dynamic arrays, we could call Ubound(inputValues,2) once outside of the loop
' And assign the result to a Long type variable
' To avoid calling Ubound() 250k times within the loop itself.
For rowIndex = 1 To TOTAL_ROWS
For columnIndex = 1 To TOTAL_COLUMNS
interimArray(columnIndex) = inputValues(rowIndex, columnIndex)
Next columnIndex
outputArray(rowIndex) = VBA.Strings.Join(interimArray, ",")
Next rowIndex
Dim concatenatedOutput As String
concatenatedOutput = VBA.Strings.Join(outputArray, vbNewLine)
Debug.Print concatenatedOutput
' My current machine isn't particularly great
' but the code above ran and concatenated values in range A1:V250000
' (with each cell containing a random 3-character string) in under 4 seconds.
End Sub
I have seen multiple codes regarding this topic but I can't seem to understand it.
For instance, if I have a column that records people names, I want to record all unique names into the array.
So if I have a column of names
David
Johnathan
Peter
Peter
Peter
Louis
David
I want to utilize VBA to extract unique names out of the column and place it into an array so when I call the array it would return these results
Array[0] = David
Array[1] = Johnathan
Array[2] = Peter
Array[3] = Louis
Despite a Collection being mentioned and being a possible solution, it is far more efficient to use a Dictionary as it has an Exists method. Then it's just a matter of adding the names to the dictionary if they don't already exist, and then extracting the keys to an array when you're done.
Note that I've made the name comparisons case-sensitive, but you can change that if necessary, to case-insensitive.
Option Explicit
Sub test()
'Extract all of the names into an array
Dim values As Variant
values = Sheet1.Range("Names").Value2 'Value2 is faster than Value
'Add a reference to Microsoft Scripting Runtime
Dim dic As Scripting.Dictionary
Set dic = New Scripting.Dictionary
'Set the comparison mode to case-sensitive
dic.CompareMode = BinaryCompare
Dim valCounter As Long
For valCounter = LBound(values) To UBound(values)
'Check if the name is already in the dictionary
If Not dic.Exists(values(valCounter, 1)) Then
'Add the new name as a key, along with a dummy value of 0
dic.Add values(valCounter, 1), 0
End If
Next valCounter
'Extract the dictionary's keys as a 1D array
Dim result As Variant
result = dic.Keys
End Sub
use Dictionary object and build a Function that returns your array
Function GetUniqeNames(myRng As Range) As Variant
Dim cell As Range
With CreateObject("Scripting.Dictionary") ' instantiate and reference a Dictionary object
For Each cell In myRng ' loop through passed range
.Item(cell.Value2) = 1 ' store current cell name into referenced dictionary keys (duplicates will be overwritten)
Next
GetUniqeNames = .keys ' write referenced dictionary keys into an array
End With
End Function
that you can exploit in your main code as follows
Sub main()
Dim myArray As Variant
With Worksheets("mysheet") ' change "mysheet" to your actual sheet name
myArray = GetUniqeNames(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp))) ' this will take the referenced sheet column A range from row 1 down to last not empty one
End With
End Sub
Is this a VBA question or a question about programming logic? Use a loop on the column with the data. Check each name against the list of existing data items. If it exists in the list, move on the the next name. If it does not exist in the list, add it.
The "list" is a concept, not a concrete tool. It can be a VBA dictionary, if you are comfortable using that. Or it can be a VBA array, which may not perform as fast as a dictionary, but may be more familiar.
Then again, if you add the data to the Excel Data Model, you can use the Distinct aggregation of a pivot table to list out the unique values.
Without more background it's hard to tell if VBA or Data Model is your best approach. Many VBA solutions get created because people are not aware of Excel's capabilities.
You could use Excel functionality like that.
Sub UniqueNames()
Dim vDat As Variant
Dim rg As Range
Dim i As Long
Set rg = Range("A1:A7")
rg.RemoveDuplicates Columns:=Array(1), Header:=xlNo
With ActiveSheet
vDat = WorksheetFunction.Transpose(.Range("A1:" & .Range("A1").End(xlDown).Address))
End With
For i = LBound(vDat) To UBound(vDat)
Debug.Print vDat(i)
Next i
End Sub
Code is based on your example data, i.e. I put your data into column 1. But the code will also alter the table. If you do not want that you have to use other solutions or put the data beforehand in a temporary sheet.
If you dont want to use "Scripting.Dictionary" and your excel does not have Worksheet.unique(...) like mine
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
If UBound(arr) >= 0 Then
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
Else
IsInArray = False
End If
End Function
Public Function GetUniqueValuesFromColumn(ws As Worksheet, sourceColNum As Long, Optional firstRow As Long = 2) As Variant
Dim val As String
Dim i As Long
Dim arr() As Variant
arr = Array()
For i = firstRow To ws.Cells(Rows.Count, sourceColNum).End(xlUp).Row
val = ws.Cells(i, sourceColNum)
If Not IsInArray(val, arr) Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = val
End If
Next i
GetUniqueValuesFromColumn = arr
End Function
Then call it like GetUniqueValuesFromColumn(ThisWorkbook.Worksheets("SomeList"), 1)
I have a macro that so far, adds 4 new table columns to an existing table ("Table1"). Now, I would like the macro to format the 3rd and 4th row as percentage. I would like to include this in the loop already listed in my code. I have tried several different ways to do this. I don't think I quite understand how the UBound function works, but hopefully you can understand what I am trying to do.
I also am unsure if I am allowed to continue to utilize the WITH statement in my nested For loop in regards to me 'lst' variable.
#Jeeped - I'm looking at you for this one again...thanks for basically walking me through this whole project lol
Sub attStatPivInsertTableColumns_2()
Dim lst As ListObject
Dim currentSht As Worksheet
Dim colNames As Variant, r1c1s As Variant
Dim h As Integer, i As Integer
Set currentSht = ActiveWorkbook.Sheets("Sheet1")
Set lst = ActiveSheet.ListObjects("Table1")
colNames = Array("AHT", "Target AHT", "Transfers", "Target Transfers")
r1c1s = Array("=([#[Inbound Talk Time (Seconds)]]+[#[Inbound Hold Time (Seconds)]]+[#[Inbound Wrap Time (Seconds)]])/[#[Calls Handled]]", "=350", "=[#[Call Transfers and/or Conferences]]/[#[Calls Handled]]", "=0.15")
With lst
For h = LBound(colNames) To UBound(r1c1s)
.ListColumns.Add
.ListColumns(.ListColumns.Count).Name = colNames(h)
.ListColumns(.ListColumns.Count).DataBodyRange.FormulaR1C1 = r1c1s(h)
If UBound(colNames(h)) = 2 or UBound(colNames(h)) = 3 Then
For i = UBound(colNames(h), 2) To UBound(colNames(h), 3)
.ListColumns(.ListColumns.Count).NumberFormat = "0%"
End if
Next i
Next h
End With
End Sub
You don't need to nest a second for loop. If you want to set the 3rd and 4th columns to a percentage, you only need to set that when the iteration of the loop (h) is 2 or 3 (remembering that arrays index from 0). You also shouldn't cross arrays for the main loop, and since LBound is in most cases 0 you might as well just use that anyway. Try this:
With lst
For h = 0 To UBound(r1c1s)
.ListColumns.Add
.ListColumns(.ListColumns.Count).Name = colNames(h)
.ListColumns(.ListColumns.Count).DataBodyRange.FormulaR1C1 = r1c1s(h)
If h = 2 or h = 3 Then
.ListColumns(.ListColumns.Count).NumberFormat = "0%"
End if
Next h
End With
To answer the other point in your question, UBound(array) just gives the index of the largest element (the Upper BOUNDary) in the given array. So where you have 50 elements in such an array, UBound(array) will return 49 (zero based as mentioned before). LBound just gives the other end of the array (the Lower BOUNDary), which is generally zero.
I currently have a method which takes in a dynamic named range in excel and converts it to a 2D array.
I need to do some iterations to the data and carry out a Delete function if a certain column contains a value. I have looked at the options out there for deleting rows in 2d array using transpose and temp array and since my data is fairly large I am looking at other data structures that would make it easier to delete entire rows.
I want to convert a dynamic named range into a collection in vba. This collection will have a key the row number and as item should have all the data for that row. Basically I would need the ability to iterate through each value in that range like I can do with a 2D array but also the ability to delete a row efficiently and with less hassle than using a 2D array.
Anybody have an idea on how I can achieve this?
Dim srcArray () As Variant
Dim srcRange As Range
srcRange = ThisWorkbook.Worksheets("Main").Range("myNamedRange")
srcArray = srcRange.Value
Dim rowNr As Long
dim colNr As Long
for rowNr = 1 to UBound(srcArray,1)
if srcArray(rowNr, 9) = "testString" Then Call DeleteRowSub(srcArray, rowNr)
Next rowNr
DeleteRowSub will be a sub which will delete a given row based on the index of that row. I want to get away from that and just be able to say something like srcCollection.Remove(index) with index being the row nr.
Any help, greatly appreciated.
There's no secret to this. It's just housekeeping.
Function ReadRangeRowsToCollection(r As Range) As Collection
Dim iRow As Long
Dim iCol As Long
Dim rangeArr As Variant
Dim rowArr As Variant
Dim c As Collection
'Read range content to Variant array
rangeArr = r.Value
'Now transfer shit to collection
Set c = New Collection
For iRow = 1 To r.Rows.Count
ReDim rowArr(1 To r.Columns.Count)
For iCol = 1 To r.Columns.Count
rowArr(iCol) = rangeArr(iRow, iCol)
Next iCol
c.Add rowArr, CStr(iRow)
Next iRow
Set ReadRangeRowsToCollection = c
End Function
Example usage:
Dim c As Collection
Set c = ReadRangeRowsToCollection(Range("myNamedRange"))
c.Remove 1 ' remove first row from collection
Note: I haven't looked at edge cases; for example this will fail if the range is one cell only. Up to you to fix it.
I have a 2D array and I am trying to add along one dimension. The 2D Array is of type variant and might have some of the elements as null ("")
Here is the code so far
'newArray is 2D Array
Function SumColumn(newArray As Variant, index As Integer) As Double
Dim tempArray() As Double
ReDim tempArray(1 To UBound(newArray))
For i = 1 To (UBound(newArray))
tempArray(i) = CDbl(newArray(i, index))
Next
SumColumn = Application.WorksheetFunction.Sum(tempArray)
End Function
I get a type mismatch error when I am running the above code. Please help me debug
You are probabaly getting a Type mismatch because CDbl(newArray(i, index)) might actually not be a number.
This works for me. Please amend the code to suit your needs.
For demonstration purpose, I am storing an Excel range into a 2D array and then converting it to a 1D temp array. Once that is done, I am simply storing the relevant Numbers in the Double Array and finally calculating the sum.
Lets say that the worksheet looks like this
Option Explicit
Sub Sample()
Dim MyAr, TempAr()
Dim dAr() As Double
Dim n As Long, i As Long
MyAr = ActiveSheet.Range("A1:A10").Value
TempAr = Application.Transpose(MyAr)
ReDim dAr(0 To 0)
n = 0
For i = LBound(TempAr) To UBound(TempAr)
If Len(Trim(TempAr(i))) <> 0 Then
If IsNumeric(Trim(TempAr(i))) Then
ReDim Preserve dAr(0 To n)
dAr(UBound(dAr)) = Trim(TempAr(i))
n = n + 1
End If
End If
Next i
Debug.Print Application.WorksheetFunction.Sum(dAr)
End Sub
And this is the output