What I need:
I often need to rearrange multidimensional arrays, especially with timestamps. For that I need a routine, that results in a permanent sort order. Since the data can be huge, it has to be performant as possible.
I would like to have some feedback to my current efforts. I'm trying to understand sorting arrays practical. I'm not a programmer, if possible be patient. :)
I'll appreciate every help/tips! I'm going to learn some new things maybe.
What my efforts are so far:
For the beginning I took the bubble sort algorithm. It does what is needed, BUT its performance is very low. It needs more than 20 seconds for sorting a column within 582 rows and 114 columns.
The code works with single- and multi-column-arrays. I use regular expressions, so keep in mind the little function a the end of the code.
I've commented my code step by step, I hope its still readable.
I know QuickSort would be much faster, but I haven't understand to make this algorithm permanent/stable yet. I've found this solution Sorting a multidimensionnal array in VBA, but as said, its not permanent.
Especially for Excel I know the way to copy an array to a worksheet and to sort it there. My goal is to avoid this solution. :)
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ BubbleSort_Array
'+
'+ Sort algorithm: BubbleSort
'+ Sorts by: 1. numbers, 2. dates, 3. Zeichenketten (also with consecutive number, e.g. "Book1,Book2,Book3..."; Capital letters before small letters)
'+ Parameter "Data": Requires an array (VARIANT) with one or more columns and rows, by reference
'+ Paramater "Column" is a LONG, follows the counting by "Option Base 0" (first column = 0)
'+ Parameter "Direction" is an EXCEL-based constant, that determines the sortdirection (ascending/descending)
'+
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub BubbleSort_Array( _
ByRef Data() As Variant, _
Optional Column As Long = -1, _
Optional Direction As XlSortOrder = 1 _
)
Dim InnerIndex As Long 'common variable, for the inner loop
Dim OuterIndex As Long 'common variable, for the outer loop
Dim SwapItem As Variant 'variable to temporarily save content, that could be swapped with another item
Dim SwapItem2 As Variant 'variable to temporarily save content, that could be swapped with another item
Dim ErrNum As Long 'variable for error number of the ERR-object
Dim lngRow As Long 'common variable for the rows of an array
Dim lngColumn As Long 'common variable for the column of an array
Dim colNumber As New Collection 'variable to save a part of digits from an entry
Dim colText As New Collection 'variable to save a part of text from an entry
Dim colDates As New Collection 'variable to save dates from an entry
Dim SortIndex() As Variant 'array for sorting and mapping the specified COLUMN
Dim CopyData() As Variant 'array for the original data, but sorted
'Check, whether the given array is a one- or multi-column array
On Error Resume Next
ErrNum = UBound(Data, 2)
ErrNum = Err.Number
On Error GoTo 0
'If there is an error and the parameter COLUMN is still -1 the parameter DATA is an one-column-array
If ErrNum > 0 And Column = -1 Then
'Outer loop
For OuterIndex = LBound(Data) To UBound(Data)
'Inner loop
For InnerIndex = LBound(Data) To UBound(Data)
'Execute the following statement as long the current index is not the last one (it would throw an error 9 by trying to access the next item)
If InnerIndex < UBound(Data) Then
'To differentiate between the values
'Check, whether the value and the next value are dates
If VBA.IsDate(Data(InnerIndex)) And VBA.IsDate(Data(InnerIndex + 1)) Then
'Save the dates in a temporary collection
colDates.Add VBA.CDate(Data(InnerIndex)), "date1"
colDates.Add VBA.CDate(Data(InnerIndex + 1)), "date2"
Else
'If both values are not dates, split the value in case it is a STRING with an number at the end
'like "Paper1", "Paper2" etc.
colNumber.Add RegEx_Replace(Data(InnerIndex), ".*(\d+$)", "$1"), "current"
colNumber.Add RegEx_Replace(Data(InnerIndex + 1), ".*(\d+$)", "$1"), "next"
colText.Add RegEx_Replace(Data(InnerIndex), "(.*)\d+$", "$1"), "current"
colText.Add RegEx_Replace(Data(InnerIndex + 1), "(.*)\d+$", "$1"), "next"
End If
'Check, whether the sortdirection is ascending
If Direction = xlAscending Then
'Sort by date
If VBA.IsDate(Data(InnerIndex)) And VBA.IsDate(Data(InnerIndex + 1)) Then
'Check the items depending from the sortdirection
If VBA.CDbl(colDates("date1")) > VBA.CDbl(colDates("date2")) Then
'In case the first item is bigger then the second, swap the items
SwapItem = Data(InnerIndex)
Data(InnerIndex) = Data(InnerIndex + 1)
Data(InnerIndex + 1) = SwapItem
End If
'Sort by strings with consecutive number
ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) _
And (colText("current") = colText("next")) Then
'In case the first item is bigger then the second, swap the items
If colNumber("current") > colNumber("next") Then
SwapItem = Data(InnerIndex)
Data(InnerIndex) = Data(InnerIndex + 1)
Data(InnerIndex + 1) = SwapItem
End If
Else
'Sort by strings
'In case the first item is bigger then the second, swap the items
If Data(InnerIndex) > Data(InnerIndex + 1) Then
SwapItem = Data(InnerIndex)
Data(InnerIndex) = Data(InnerIndex + 1)
Data(InnerIndex + 1) = SwapItem
End If
End If
'Sort descending
Else
'Sort descending
'Sort by date
If VBA.IsDate(Data(InnerIndex)) And VBA.IsDate(Data(InnerIndex + 1)) Then
If VBA.CDbl(colDates("date1")) < VBA.CDbl(colDates("date2")) Then
'In case the first item is smaller then the second, swap the items
SwapItem = Data(InnerIndex)
Data(InnerIndex) = Data(InnerIndex + 1)
Data(InnerIndex + 1) = SwapItem
End If
'Sort by strings with consecutive number
ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) And _
(colText("current") = colText("next")) Then
'In case the first item is smaller then the second, swap the items
If colNumber("current") < colNumber("next") Then
SwapItem = Data(InnerIndex)
Data(InnerIndex) = Data(InnerIndex + 1)
Data(InnerIndex + 1) = SwapItem
End If
Else
'Sort by strings
'In case the first item is smaller then the second, swap the items
If Data(InnerIndex) < Data(InnerIndex + 1) Then
SwapItem = Data(InnerIndex)
Data(InnerIndex) = Data(InnerIndex + 1)
Data(InnerIndex + 1) = SwapItem
End If
End If
End If
End If
Set colNumber = Nothing
Set colText = Nothing
Set colDates = Nothing
Next
Next
Else
'Resize the array SortIndex for sorting the specified COLUMN
'Needs two columns: One for the index of the original data, and one for the values to be sorted
ReDim SortIndex(UBound(Data, 1), 1)
For InnerIndex = LBound(Data, 1) To UBound(Data, 1)
'Save index of the original data
SortIndex(InnerIndex, 0) = InnerIndex
'Save values of the specified COLUMN
SortIndex(InnerIndex, 1) = Data(InnerIndex, Column)
Next
'Outer loop
For OuterIndex = LBound(SortIndex, 1) To UBound(SortIndex, 1)
'Inner loop
For InnerIndex = LBound(SortIndex, 1) To UBound(SortIndex, 1)
'Execute the following statement as long the current index is not the last one (it would throw an error 9 by trying to access the next item)
If InnerIndex < UBound(SortIndex, 1) Then
'To differentiate between the values
'Check, whether the value and the next value are dates
If VBA.IsDate(SortIndex(InnerIndex, 1)) And VBA.IsDate(SortIndex(InnerIndex + 1, 1)) Then
'Save the dates in a temporary collection
colDates.Add VBA.CDate(SortIndex(InnerIndex, 1)), "date1"
colDates.Add VBA.CDate(SortIndex(InnerIndex + 1, 1)), "date2"
Else
'If both values are not dates, split the value in case it is a STRING with an number at the end
'like "Paper1", "Paper2" etc.
colNumber.Add RegEx_Replace(SortIndex(InnerIndex, 1), ".*(\d+$)", "$1"), "current"
colNumber.Add RegEx_Replace(SortIndex(InnerIndex + 1, 1), ".*(\d+$)", "$1"), "next"
colText.Add RegEx_Replace(SortIndex(InnerIndex, 1), "(.*)\d+$", "$1"), "current"
colText.Add RegEx_Replace(SortIndex(InnerIndex + 1, 1), "(.*)\d+$", "$1"), "next"
End If
'Check the sortdirection
If Direction = xlAscending Then
'Sort by date
If VBA.IsDate(SortIndex(InnerIndex, 1)) And VBA.IsDate(SortIndex(InnerIndex + 1, 1)) Then
If VBA.CDbl(colDates("date1")) > VBA.CDbl(colDates("date2")) Then
'In case the first item is bigger then the second, swap the items
SwapItem = SortIndex(InnerIndex, 0)
SwapItem2 = SortIndex(InnerIndex, 1)
SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
SortIndex(InnerIndex + 1, 0) = SwapItem
SortIndex(InnerIndex + 1, 1) = SwapItem2
End If
'Sort by strings with consecutive numbers
ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) _
And (colText("current") = colText("next")) Then
'In case the first item is bigger then the second, swap the items
If colNumber("current") > colNumber("next") Then
SwapItem = SortIndex(InnerIndex, 0)
SwapItem2 = SortIndex(InnerIndex, 1)
SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
SortIndex(InnerIndex + 1, 0) = SwapItem
SortIndex(InnerIndex + 1, 1) = SwapItem2
End If
Else
'Sort by strings
'In case the first item is bigger then the second, swap the items
If SortIndex(InnerIndex, 1) > SortIndex(InnerIndex + 1, 1) Then
SwapItem = SortIndex(InnerIndex, 0)
SwapItem2 = SortIndex(InnerIndex, 1)
SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
SortIndex(InnerIndex + 1, 0) = SwapItem
SortIndex(InnerIndex + 1, 1) = SwapItem2
End If
End If
Else
'Sort descending
'Sort by dates
If VBA.IsDate(SortIndex(InnerIndex, 1)) And VBA.IsDate(SortIndex(InnerIndex + 1, 1)) Then
'In case the first item is smaller then the second, swap the items
If VBA.CDbl(colDates("date1")) < VBA.CDbl(colDates("date2")) Then
SwapItem = SortIndex(InnerIndex, 0)
SwapItem2 = SortIndex(InnerIndex, 1)
SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
SortIndex(InnerIndex + 1, 0) = SwapItem
SortIndex(InnerIndex + 1, 1) = SwapItem2
End If
'Sort by strings with consecutive numbers
ElseIf VBA.IsNumeric(colNumber("current")) And VBA.IsNumeric(colNumber("next")) And _
(colText("current") = colText("next")) Then
'In case the first item is smaller then the second, swap the items
If colNumber("current") < colNumber("next") Then
SwapItem = SortIndex(InnerIndex, 0)
SwapItem2 = SortIndex(InnerIndex, 1)
SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
SortIndex(InnerIndex + 1, 0) = SwapItem
SortIndex(InnerIndex + 1, 1) = SwapItem2
End If
Else
'Sort by strings
If SortIndex(InnerIndex, 1) < SortIndex(InnerIndex + 1, 1) Then
'In case the first item is smaller then the second, swap the items
SwapItem = SortIndex(InnerIndex, 0)
SwapItem2 = SortIndex(InnerIndex, 1)
SortIndex(InnerIndex, 0) = SortIndex(InnerIndex + 1, 0)
SortIndex(InnerIndex, 1) = SortIndex(InnerIndex + 1, 1)
SortIndex(InnerIndex + 1, 0) = SwapItem
SortIndex(InnerIndex + 1, 1) = SwapItem2
End If
End If
End If
End If
Set colNumber = Nothing
Set colText = Nothing
Set colDates = Nothing
Next
Next
'Resize a new array with the same size like the original DATA
ReDim CopyData(UBound(Data, 1), UBound(Data, 2))
'Write the data according to the array SortIndex (= sorts the whole original data)
For lngRow = LBound(Data, 1) To UBound(Data, 1)
For lngColumn = LBound(Data, 2) To UBound(Data, 2)
CopyData(lngRow, lngColumn) = Data(SortIndex(lngRow, 0), lngColumn)
Next
Next
'Overwrite the original data with the sorted data
For lngRow = LBound(Data, 1) To UBound(Data, 1)
For lngColumn = LBound(Data, 2) To UBound(Data, 2)
Data(lngRow, lngColumn) = CopyData(lngRow, lngColumn)
Next
Next
End If
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ RegEx_Replace
'+
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Function RegEx_Replace( _
varString As Variant, _
strSearchPattern As String, _
strReplaceString As String, _
Optional blnCase_Insensitive As Boolean = True, _
Optional blnGlobalSearch As Boolean = True, _
Optional blnMultiLine As Boolean = False _
) As String
Dim RegEx As Object
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.IgnoreCase = blnCase_Insensitive
.Global = blnGlobalSearch
.MultiLine = blnMultiLine
.Pattern = strSearchPattern
End With
RegEx_Replace = RegEx.Replace(varString, strReplaceString)
End Function
Here's a slightly different approach - broken out some of the functionality into separate methods but the main Sub has a similar signature to yours (with one additional parameter)
'run some tests
Sub Tester()
Dim arr
BubbleSort_Array Array(), 1 'empty array: does nothing
arr = Array(5, 4, 1, 3, 2)
BubbleSort_Array arr, 1
[P1].Resize(1, UBound(arr) + 1).Value = arr
'1-dimensional array
arr = Array("1 Title", "2 Title", "10 Title", "33 Title", "16 Title", "blah")
BubbleSort_Array arr, 1 'sort raw values
[P2].Resize(1, UBound(arr) + 1).Value = arr
arr = Array("1 Title", "2 Title", "10 Title", "33 Title", "16 Title", "blah")
BubbleSort_Array arr, 1, "SortOnVal" 'sort on Val() transformation
[P3].Resize(1, UBound(arr) + 1).Value = arr
arr = Array("1 Title", "2 Title", "10 Title", "33 Title", "16 Title", "blah")
BubbleSort_Array arr, 1, "SortOnVal", xlDescending 'sort on Val() transformation, descending
[P4].Resize(1, UBound(arr) + 1).Value = arr
'2-dimensional array (from A1:N22)
arr = [A1].CurrentRegion.Value
BubbleSort_Array arr, 3 'sort 2D array on third column ("Val1", "Val2",...."Val22")
[A25].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr 'sort is "ascibetical"
arr = [A1].CurrentRegion.Value
BubbleSort_Array arr, 3, "NumberOnly" 'sort 2D array on third column, after extracting a number where present
[A49].Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr 'sort looks correct
End Sub
'Sort array `data` in-place, using optional column position if 2D array
'Optional `ParseFunction` parameter is the name of a single-input function to transform values prior to sorting
Sub BubbleSort_Array(ByRef data As Variant, Optional Column As Long = -1, _
Optional ParseFunction As String = "", _
Optional Direction As XlSortOrder = 1)
Dim dims As Long, lbr As Long, lbc As Long, ubr As Long, ubc As Long, i As Long, j As Long
Dim arrSort, tmp, tmp2, swap As Boolean, arrOut
dims = Dimensions(data) 'check input array dimensions
Debug.Print "dims", dims
If dims < 1 Or dims > 2 Then Exit Sub
lbr = LBound(data, 1)
ubr = UBound(data, 1)
If dims = 1 Then data = Make2D(data) 'normalize input to 2D array (single column)
lbc = LBound(data, 2)
ubc = UBound(data, 2)
If Column = -1 Then Column = lbc 'sort defaults to first column
'make an array for sorting: first column is values to sort on, second is row indexes from `data`
' advantage is you're shuffling fewer items when sorting, and expensive transformations only run once
ReDim arrSort(lbr To ubr, 1 To 2)
For i = lbr To ubr
tmp = data(i, Column) 'value to sort on
If Len(ParseFunction) > 0 Then tmp = Application.Run(ParseFunction, tmp) 'custom transformation?
arrSort(i, 1) = tmp
arrSort(i, 2) = i
Next i
'now sort the array...
For i = lbr To ubr - 1
For j = i + 1 To ubr
swap = IIf(Direction = xlAscending, arrSort(i, 1) > arrSort(j, 1), _
arrSort(i, 1) < arrSort(j, 1))
If swap Then
tmp = arrSort(j, 1) 'swap positions in the "comparison" array
tmp2 = arrSort(j, 2)
arrSort(j, 1) = arrSort(i, 1)
arrSort(j, 2) = arrSort(i, 2)
arrSort(i, 1) = tmp
arrSort(i, 2) = tmp2
End If
Next j
Next i
ReDim arrOut(lbr To ubr, lbc To ubc) 'size the output array
'using the sorted array, copy data from the original array
For i = lbr To ubr
For j = lbc To ubc
arrOut(i, j) = data(arrSort(i, 2), j)
Next j
Next i
If dims = 1 Then arrOut = Make1D(arrOut) 'switch back to 1D if input was 1D
data = arrOut 'replace the input array in-place
End Sub
'return result of Val()
Function SortOnVal(v)
SortOnVal = Val(v)
End Function
'extract the first *whole* number from string `v`
Function NumberOnly(v) As Long
Dim rv, i, c
For i = 1 To Len(v)
c = Mid(v, i, 1)
If IsNumeric(c) Then
rv = rv & c
Else
If Len(rv) > 0 Then Exit For
End If
Next i
If Len(rv) = 0 Then rv = 0
NumberOnly = CLng(rv)
End Function
'----Helper functions
'find the dimension of an array
Function Dimensions(data As Variant)
Dim d As Long, ub
d = 1
Do
ub = Empty
On Error Resume Next
'Debug.Print d, LBound(data, d), UBound(data, d)
ub = UBound(data, d)
On Error GoTo 0
If ub = -1 Or IsEmpty(ub) Then Exit Do 'also checking for undimensioned case...
d = d + 1
Loop
Dimensions = d - 1
End Function
'transform a 1-D array into a 2D array (single-column)
Function Make2D(arr)
Dim i As Long, arrOut
ReDim arrOut(LBound(arr) To UBound(arr), 1 To 1)
For i = LBound(arr) To UBound(arr)
arrOut(i, 1) = arr(i)
Next i
Make2D = arrOut
End Function
'transform a single-column 2-D array into a 1D array
Function Make1D(arr)
Dim i As Long, arrOut
ReDim arrOut(LBound(arr) To UBound(arr))
For i = LBound(arr) To UBound(arr)
arrOut(i) = arr(i, 1)
Next i
Make1D = arrOut
End Function
Weird, I thought I uploaded this screenshot yesterday:
As you see, you can check the "Data" ribbon, "Filter&Sort" choice, and off you go.
So, I've decided to use the excel-worksheet-method. Thanks for Dominique and Ron Rosenfeld.
Beside the good performance it sorts dates and numbers right.
Here is my code:
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+
'+ Sort_by_Excel
'+
'+ Sort algorithm: Excel
'+ Sorts by: 1. numbers, 2. dates, 3. strings
'+ Parameter "arrData": Requires an array (VARIANT) with one or more columns and rows, by reference
'+ Parameter "wsWorksheet": a worksheet to copy and sort the data
'+ Paramater "Column" is a LONG, follows the normal counting for worksheets (first column = 1)
'+ Parameter "SortDirection" is an EXCEL-based constant, that determines the sortdirection (ascending/descending)
'+
'+ Current performance: 582 rows and 114 columns are sorted in <1 sec
'+ Works with Option Base 0 and 1
'+
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Public Sub Sort_by_Excel( _
ByRef arrData As Variant, _
wsWorksheet As Worksheet, _
Optional Column As Long, _
Optional SortDirection As XlSortOrder = 1 _
)
Dim rngKey As Range
Dim rngSortRange As Range
Dim lngRow As Long
Dim lngColumn As Long
Dim lngErrNumber As Long
'Check, whether it is a single-column array or multi-column array
On Error Resume Next
lngErrNumber = UBound(arrData, 2)
lngErrNumber = Err.Number
On Error GoTo 0
'Code for multi-column array
If lngErrNumber = 0 Then
'If COLUMN is not in the range of existing columns leave the sub, data is still unsorted
If Column < LBound(arrData, 1) + 1 - LBound(arrData, 1) And Column > UBound(arrData, 2) + 1 - LBound(arrData, 2) Then Exit Sub
With wsWorksheet
'Remove everything from the worksheet
.Cells.Clear
'Define a key cell for sorting (the first cell of to be sorted column)
Set rngKey = .Cells(1, Column)
'Define the range, where the data will be copied to
'Size of arrData
Set rngSortRange = .Range( _
.Cells(1, 1), .Cells( _
UBound(arrData, 1) + 1 - LBound(arrData, 1), _
UBound(arrData, 2) + 1 - LBound(arrData, 2)) _
)
End With
With rngSortRange
'Copy the data to the range
.Value = arrData
'Sort the range
.CurrentRegion.Sort _
Key1:=rngKey, _
Order1:=SortDirection, _
Orientation:=xlTopToBottom
'Overwrite the original data
For lngRow = 1 To .Rows.Count
For lngColumn = 1 To .Columns.Count
arrData((lngRow - 1) + LBound(arrData, 1), (lngColumn - 1) + LBound(arrData, 2)) = .Cells(lngRow, lngColumn).Value
Next
Next
End With
Else
'Code for single-column array, same as above
With wsWorksheet
.Cells.Clear
Set rngKey = .Cells(1, 1)
Set rngSortRange = .Range( _
.Cells(1, 1), .Cells(UBound(arrData) + 1, 1) _
)
End With
With rngSortRange
'Copy the data to range, original array has to transposed (rotate from horizontal to vertical)
.Value = Application.Transpose(arrData)
.CurrentRegion.Sort _
Key1:=rngKey, _
Order1:=SortDirection, _
Orientation:=xlTopToBottom
'Overwrite the original data with the sorted data
For lngRow = 1 To .Rows.Count
arrData((lngRow - 1) + LBound(arrData, 1)) = .Cells(lngRow, 1).Value
Next
End With
End If
End Sub
Related
I have an array full of data that I want to write in a worksheet.
I obtain 2 differents results while doing this :
1) Looping through indexes
For i = 0 To UBound(dataarray(), 1)
For j = 0 To UBound(dataarray(), 2)
With mWS_data
.Cells(i + 2, j + 1) = dataarray(i, j)
End With
Next j
Next i
2) Filling the range directly
With mWS_data
'Row + 2 because datarray starts from 0, and 1st row is titles, Column + 1 because same reason but no titles
.Range(.Cells(2, 1), .Cells(UBound(dataarray(), 1) + 2, UBound(dataarray(), 2) + 1)) = dataarray()
End With
With the same data, in the first case I have all the data in the worksheet (correct result) and in the second case, I only have few datas (all the correct info of one column in the middle, and 1 cell with correct info on an other column).
My code was working perfectly fine last friday, there was absolutly no change in the code and today it is not working correctly.
I am use to code the second way because of much faster processing time.
Is it possible that an excel setup interfer somehow ?
Or did I wrote somehting wrong ?
--- EDIT : ---
Here is the full code with the simplifications you gave me
Sub Load()
Dim dataArray() As Variant
Dim i As Long
Dim j As Long
Dim c_attribute As New Cls_attribute
ReDim dataArray(mJobs.Count - 1, attributes.Count - 1)
'Turns off screen updating and auto calculation
DisplayCalculation False
'For each item into collection
For i = 1 To mJobs.Count
Index = i
'Get data from its variable name
For j = 1 To attributes.Count
Set c_attribute = attributes.Item(j)
On Error Resume Next
dataArray(i - 1, j - 1) = CallByName(Me, c_attribute.name, VbGet)
On Error GoTo 0
Set c_attribute = Nothing
Next j
Next i
With mWS_data
'Remove previous data
.Rows("2:" & Rows.Count).Delete
'Data to worksheet '[VERSION THAT WORKS]
For i = 0 To UBound(dataArray, 1)
For j = 0 To UBound(dataArray, 2)
.Cells(i + 2, j + 1) = dataArray(i, j)
Next j
Next i
'Data to worksheet '[VERSION THAT FAILS]
'.Range("A2").Resize(UBound(dataArray, 1) + 1, UBound(dataArray, 2) + 1).Value = dataArray
End With
'Turns in screen updating and auto calculation
DisplayCalculation True
End Sub
Though I can not show you the data because it is confidential and not GDPR compliant :
When it works : 56 rows and 68 columns of datas complete
When it fails : same range is filled, but only "AG" column and "AH44" cell contain datas.
Write a 2D Zero-Based Array to a Worksheet
Option Explicit
Sub WriteArrayToWorksheet()
Dim DataArray As Variant: ReDim DataArray(0 To 4, 0 To 9) ' 5*10, 'A2:J6'
Dim r As Long
Dim c As Long
For r = 0 To 4
For c = 0 To 9
DataArray(r, c) = (r + 1) * (c + 1)
Next c
Next r
' Remember: 'UBound(DataArray, 1)', 'UBound(DataArray,2)', 'DataArray'.
' Correct: .Range(.Cells(2, 1), .Cells(UBound(DataArray, 1) + 2, UBound(DataArray, 2) + 1)).Value = DataArray
' Wrong: .Range(.Cells(2, 1), .Cells(UBound(DataArray(), 1) + 2, UBound(DataArray(), 2) + 1)) = DataArray()
With mWS_data
' Row + 2 because DataArray starts from 0, and 1st row is titles, Column + 1 because same reason but no titles
' Correct:
.Range(.Cells(2, 1), .Cells(UBound(DataArray, 1) + 2, UBound(DataArray, 2) + 1)).Value = DataArray
' I prefer using 'Resize':
'.Range("A2").Resize(UBound(DataArray, 1) + 1, UBound(DataArray, 2) + 1).Value = DataArray
End With
End Sub
When I paste my array as such,
Set rngPaste = wksSkillsDist.Cells(iStartRow, iFirstColTotal)
rngPaste.Resize(UBound(arrTotals, 1), UBound(arrTotals, 2)) = arrTotals
I get #N/A values that are outside the bounds of my array. In my array, there are no #N/A values.
This is how I declare my Arrray
With wksSkillsDist
'get last Column
iColLastCategory = .Cells(iStartRow - 1, 2).End(xlToRight).Column
'Create array which the indicies match the cells where values will go
ReDim arrTotals(iStartRow To .Cells(iStartRow, iSkillCodeColumn).End(xlDown).Row, 2 To iColLastCategory) As Variant
End With
Here is an example of how items are added to arrTotals. Basically, check to see if certain strings match. If they match then I increment the corresponding spot in the array:
For iColumn = iFirstColPrimary To iLastColPrimary
If szLevel = "Mastered" Then
If InStr(1, wksSkillsDist.Cells(iHeaderRow - 1, iColumn), "Mastered", vbTextCompare) <> 0 And _
StrComp(wksSkillsDist.Cells(iHeaderRow - 2, iColumn).Text, szELM) = 0 And bMasterMatch = False Then
iHeaderCol = iColumn
bMasterMatch = True
iTotal = iTotal + 1
End If
ElseIf szLevel = "Developing" Then
If InStr(1, wksSkillsDist.Cells(iHeaderRow - 1, iColumn), "Developing", vbTextCompare) <> 0 And _
StrComp(wksSkillsDist.Cells(iHeaderRow - 2, iColumn).Text, szELM) = 0 And bMasterMatch = False Then
iHeaderCol = iColumn
bDevelopingMatch = True
iTotal = iTotal + 1
End If
End If
Next iColumn
If bMasterMatch = True Or bPerformingMatch = True Or bDevelopingMatch = True Then
If iTotal > 1 Then
Debug.Print "ERROR"
End If
arrTotals(iSkillRow, iHeaderCol) = arrTotals(iSkillRow, iHeaderCol) + 1
End If
When I paste my values on the sheet using a Loop like such, I get no #N/A Values
'for first y coordinate to last y coordinate in array
For iRow = LBound(arrTotals, 1) To UBound(arrTotals, 1)
'for first x coordinate to last x coordinate in array
For iColumn = LBound(arrTotals, 2) To UBound(arrTotals, 2)
'Add items to SkillDist worksheet
wksSkillsDist.Cells(iRow, iColumn).Value = arrTotals(iRow, iColumn)
Next iColumn
Next iRow
Why is this happening?
Range Size Larger Than Array Size (#N/A)
A Quick Fix
Your array is not a one-based array i.e. its 'LBounds' are not 1 but iStartRow and 2.
Your code is trying to fit the values of the array into a larger range a number of times i.e. e.g. assuming the number of columns is equal, if you're trying to fit an array of 3 rows into a range of 8 rows, it can't be done. If it were 6 or 9 rows, the array would have been written two or three times respectively.
Of course, you want to fit it one time into the correct range. Study the material following this solution.
rngPaste.Resize(UBound(arrTotals, 1) - LBound(arrTotals, 1) + 1, _
UBound(arrTotals, 2) - LBound(arrTotals, 2) + 1) = arrTotals
Any-Based
The number of rows (1st dimension) of any 2D array is calculated in the following way:
Dim rCount as long: rCount = UBound(Data, 1) - LBound(Data, 1) + 1
Similarly, the number of columns (2nd dimension) of any 2D array is calculated in the following way:
Dim cCount as long: cCount = UBound(Data, 2) - LBound(Data, 2) + 1
One-Based
Conveniently, to write the values of a range to a 2D one-based array, if there are at least two cells, one can simply do:
Dim rg As Range: Set rg = Sheet1.Range("A1:J10")
Dim Data As Variant: Data = rg.Value
Conveniently, using what we learned at the beginning, the number of rows in this 2D one-based array is equal to its UBound (since LBound = 1):
Dim rCount As Long: rCount = Ubound(Data, 1) - 1 + 1 ' or...
rCount = Ubound(Data, 1)
Similarly, the number of columns in this 2D one-based array is equal to its UBound (since LBound = 1):
Dim cCount As Long: cCount = Ubound(Data, 2) - 1 + 1 ' or...
cCount = Ubound(Data, 2)
A Small Study
Copy the following code into a standard module, e.g. Module1, of a new workbook. Play with (modify) the constants.
Note that if you set rStart and cStart to 1, the correct result will show in any case. This isn't covered because it would too much complicate the code.
Option Explicit
Sub RangeVsArray()
Const ProcName As String = "RangeVsArray"
' Imagine these are the results of you 'Range.End property' business.
Const rStart As Long = 6
Const rEnd As Long = 8
Const cStart As Long = 2
Const cEnd As Long = 14
Dim Data As Variant: ReDim Data(rStart To rEnd, cStart To cEnd)
' ... i.e.
'ReDim Data(6 To 8, 2 To 14)
' Populate the array (not relevant).
Dim r As Long, c As Long
For r = LBound(Data, 1) To UBound(Data, 1)
For c = LBound(Data, 2) To UBound(Data, 2)
Data(r, c) = r * c
Next c
Next r
Sheet1.Cells.Clear
Dim dCell As Range: Set dCell = Sheet1.Range("A1")
Dim drg As Range
Dim rCount As Long
Dim cCount As Long
' Wrong:
Set drg = dCell.Resize(UBound(Data, 1), UBound(Data, 2))
drg.Value = Data
Dim msg As Long
msg = MsgBox("This is wrong. Do you want to see the correct result?", _
vbYesNo + vbExclamation, ProcName)
If msg = vbYes Then
drg.Clear
' Correct...
rCount = rEnd - rStart + 1 ' it's not rEnd (Ubound(Data, 1))
cCount = cEnd - cStart + 1 ' it's not cEnd (Ubound(Data, 2))
' ... i.e.:
'Dim rCount As Long: rCount = UBound(Data, 1) - LBound(Data, 1) + 1
'Dim cCount As Long: cCount = UBound(Data, 2) - LBound(Data, 2) + 1
Set drg = dCell.Resize(rCount, cCount)
drg.Value = Data
MsgBox "You are watching the correct result.", vbInformation, ProcName
Else
MsgBox "You are watching the wrong result.", vbInformation, ProcName
End If
End Sub
first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function
i=19
With ListBox1
'clearing previous values from sheet
range(Cells(i + 2, 1).Address & ":" & Cells(endRwow, 7).Address).ClearContents
ListBoxArrSelected = vbNullString
For y = 0 To .ListCount - 1
If .Selected(y) Then
' concatenate all selected strings
ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
End If
Next y
' fill array with concatenated all selected strings spliting to rows
ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")
For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
' fill array with concatenated all selected strings spliting to colomuns
ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
For URc = 1 To UBound(ListBoxArrSplitToCell, 1) + 1
'paste to sheet
Cells(i + UR, 1).value = timeStr
Cells(i + UR, URc + 1).value = ListBoxArrSplitToCell(URc - 1)
Next URc
Next UR
End With
Then in listbox selected > 100 field excel responds very slow to copy them to worksheet
How to speed up this code?
You can reduce the number of cell writes using something like this:
i = 19
With ListBox1
Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents
ListBoxArrSelected = vbNullString
For y = 0 To .ListCount - 1
If .Selected(y) Then
ListBoxArrSelected = ListBoxArrSelected & "~" & ListBox1.List(y)
End If
Next y
ListBoxArrSplitToRows = Split(ListBoxArrSelected, "~")
Cells(i + 1, 1).Resize(UBound(ListBoxArrSplitToRows, 1) + 1).Value = timeStr
For UR = 1 To UBound(ListBoxArrSplitToRows, 1) + 1
ListBoxArrSplitToCell = Split(ListBoxArrSplitToRows(UR - 1), "·")
Cells(i + UR, 2).Resize(, UBound(ListBoxArrSplitToCell, 1) + 1).Value = ListBoxArrSplitToCell
Next UR
End With
If you have the same number of delimited items in each row of the listbox, you could create an array of arrays and then output that to the sheet in one write operation. Code would be something like this:
Dim ListBoxArrSplitToRows()
Dim counter As Long
Dim columnCount As Long
i = 19
Range(Cells(i + 2, 1), Cells(endRwow, 7)).ClearContents
With ListBox1
ReDim ListBoxArrSplitToRows(.ListCount - 1)
For y = 1 To .ListCount
If .Selected(y - 1) Then
' load subarray into array
ListBoxArrSplitToRows(counter) = Split(.List(y - 1), "·")
counter = counter + 1
End If
Next y
End With
' resize array to used extent
ReDim Preserve ListBoxArrSplitToRows(counter - 1)
' get column count using first subarray
columnCount = UBound(ListBoxArrSplitToRows(0)) + 1
Cells(i + 1, "B").Resize(counter, columnCount).Value = Application.Index(ListBoxArrSplitToRows, 0, 0)
or just Cells(i + 1, "B").Resize(counter, columnCount).Value = ListBoxArrSplitToRows
i wanna have a reference on one element in a 2 dimensional Array like this:
dim ary(5,5) as String
ary(1) = "Michael, Thomas, Bill, Mike, Pascal"
ary(2) = "Iphone,HTCOne,SGS4,SGS3"
'... and so on
can i write sth like this:?
For i = 0 To UBound(ary)
activMan = ary(i)
Sheets("Example").Cells(1,1) = activMan(i)
'activMan is now Michael
' so i dont have to use two variables...
End If
Next i
' in the next round activMan is going to be HTCOne
Now activMan should be a reference on ary(i) in the first Dimension and i have access on all the elements in the second dimension.
Is that possilbe or completly wrong?
EDIT:
I'il give out:
1.: Mike -> arr(0,0)
2.: Ipod -> arr(1,1)
3.: .... -> arr(2,2)
But i realized it's possible with only one variable...^^
That is completely wrong :p
Analyse this bud :)
Option Explicit
Sub build2DArray()
' 2D 5 element array
' elements 1st 2nd 3rd 4th 5th
' index 0 [0, 0][1, 0][2, 0][3, 0][4, 0]
' index 1 [0, 1][1, 1][2, 1][3, 1][4, 1]
Dim arr(0 To 5, 0 To 1) as String ' same as Dim arr(5, 1)
arr(0, 0) = "Mike"
arr(1, 0) = "Tom"
arr(2, 0) = "Bill"
arr(3, 0) = "Michael"
arr(4, 0) = "Pascal"
arr(0, 1) = "IPhone"
arr(1, 1) = "Ipod"
arr(2, 1) = "Mac"
arr(3, 1) = "ITunes"
arr(4, 1) = "IArray"
Dim i As Long, j As Long
Dim activeMan As String
For i = LBound(arr) To UBound(arr) - 1
activeMan = arr(i, 0)
Debug.Print "loop no. " & i & " activeMan: " & activeMan
Cells(i + 1, 1).Value = activeMan
Cells(i + 1, 2).Value = arr(i, 1)
Next i
End Sub
Edit: its possible to use types and a custom function to achieve the same result, have a look
Private Type yourType
tName As String
tPhone As String
End Type
Sub example()
Dim yType(3) As yourType
yType(0).tName = "Michael"
yType(0).tPhone = "iPhone"
yType(1).tName = "Tom"
yType(1).tPhone = "Blackberry"
yType(2).tName = "Dave"
yType(2).tPhone = "Samsung"
Dim i&
For i = LBound(yType) To UBound(yType)
Debug.Print get_yType(yType, i)
Next i
End Sub
Private Function get_yType(arr() As yourType, i&) As String
get_yType = arr(i).tName & " " & arr(i).tPhone
End Function