Listbox selected values paste to worksheet - arrays

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

Related

VBA Loop Using Different Color Based on Dictionary Value

Lets say I have 10 000 rows with 4 countries and I want to color entire row based on Country.
Number of countries might change so I want to keep this dynamic.
Excel File - Unique Country Values.
| Country |
| ------- |
| SWEDEN |
| FINLAND |
| DENMARK |
| JAPAN |
Firstly I do dictionary to get unique country values with code below.
data = ActiveSheet.UsedRange.Columns(1).value
Set dict = CreateObject("Scripting.Dictionary")
For rr = 2 To UBound(data)
dict(data(rr, 1)) = Empty
Next
data = WorksheetFunction.Transpose(dict.Keys())
colors_amount = dict.Count
Then I want to generate random color for each country.
Set dict_color = CreateObject("Scripting.Dictionary")
For k = 1 To colors_amount
myRnd_1 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_2 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_3 = Int(2 + Rnd * (255 - 0 + 1))
color = myRnd_1 & "," & myRnd_2 & "," & myRnd_3
dict_color.Add Key:=color, Item:=color
Next
data_color = WorksheetFunction.Transpose(dict_color.Keys())
Now it is time to create an array which combines country and color.
For k = 0 To colors_amount - 1
varArray(k, 0) = data(k + 1, 1)
varArray(k, 1) = data_color(k + 1, 1)
Next k
And now crucial part, making loop which assigns color to entire row based on country
I have no idea how to get proper color value based on Kom Value, below description what I want to do
For Each Kom In Range("A2:A" & lastrow)
'Lets Say Kom Value is Japan so I want to take from array particular RGB Color code and put it on entire row
'I want to connect to array and do VLOOKUP how can I do it ?
Next Kom
Do you have some ideas ?

Please, test the next updated code. It uses two dictionaries and should be fast, even for large ranges creating union ranges (as dictionary keys) to be colored at once, at the end of the code. It creates RGB colors:
Sub colorsToDict()
Dim myRnd_1 As Long, myRnd_2 As Long, myRnd_3 As Long
Dim sh As Worksheet, Color As Long, Data, k As Long
Dim dict As Object, dict_color As Object
Set sh = ActiveSheet
Data = sh.UsedRange.Columns(1).Value
'place unique countries in a dictionary as keys and respective range as item
Set dict = CreateObject("Scripting.Dictionary")
For k = 2 To UBound(Data)
If Not dict.Exists(Data(k, 1)) Then
Set dict(Data(k, 1)) = sh.Range("A" & k)
Else
Set dict(Data(k, 1)) = Union(dict(Data(k, 1)), sh.Range("A" & k))
End If
Next
'place colors in the dictionary item, with the same key as in above dict
Set dict_color = CreateObject("Scripting.Dictionary")
For k = 0 To dict.count - 1
myRnd_1 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_2 = Int(2 + Rnd * (255 - 0 + 1))
myRnd_3 = Int(2 + Rnd * (255 - 0 + 1))
Color = RGB(myRnd_1, myRnd_2, myRnd_3)
dict_color.Add key:=dict.keys()(k), Item:=Color
Next
'Place appropriate colors in the specific Union ranges:
For k = 0 To dict.count - 1
Intersect(dict.Items()(k).EntireRow, sh.UsedRange).Interior.Color = dict_color.Items()(k)
Next k
MsgBox "Ready..."
End Sub
Please, send some feedback after testing it

Problem solved.
I made an extra array and final loop looks like this:
ReDim varArrayv2(colors_amount - 1, 0)
For kk = 0 To colors_amount - 1
varArrayv2(kk, 0) = varArray(kk, 0)
Next kk
Final loop
For Each Kom In Range("A2:A" & lastrow)
abc = Kom.value
pos = Application.Match(abc, varArrayv2, False)
color_use = varArray(pos - 1, 1)
nr1_przecinek = InStr(1, color_use, ",")
nr2_przecinek = InStr(1 + nr1_przecinek, color_use, ",")
nr2_nawias = InStr(1 + nr1_przecinek, color_use, ")")
Kolor1 = Mid(color_use, 5, nr1_przecinek - 5)
Kolor2 = Mid(color_use, nr1_przecinek + 1, nr2_przecinek - nr1_przecinek - 1)
Kolor3 = Mid(color_use, nr2_przecinek + 1, nr2_nawias - nr2_przecinek - 1)
Kom.EntireRow.Interior.color = RGB(Kolor1, Kolor2, Kolor3)
Next Kom

This can be done with a single dictionary and using autofilter:
Sub tgr()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set to correct sheet
Dim rData As Range: Set rData = ws.UsedRange.Columns(1)
Dim aData As Variant
If rData.Cells.Count = 1 Then
MsgBox "ERROR: No data found in " & rData.Address(External:=True)
Exit Sub
Else
aData = rData.Value
End If
Dim hUnq As Object: Set hUnq = CreateObject("Scripting.Dictionary")
hUnq.CompareMode = vbTextCompare 'Make dictionary ignore case for matches (example: JAPAN = japan)
'Remove any previous coloring
rData.EntireRow.Interior.Color = xlNone
Dim i As Long
For i = 2 To UBound(aData, 1) 'Start at 2 to skip header
If Not hUnq.Exists(aData(i, 1)) Then 'Found a new unique value
hUnq(aData(i, 1)) = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256))
With rData
.AutoFilter 1, aData(i, 1)
.Offset(1).Resize(.Rows.Count - 1).EntireRow.Interior.Color = hUnq(aData(i, 1))
.AutoFilter
End With
End If
Next i
End Sub

How can I improve this sorting algorithm?

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

Why do I obtain 2 differents results when filling range directly with array and doing it index by index?

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

Optimize loop multiple variables

I have tons of data and I need to optimize this lines but i simply do not know how ...
Some lines of "x" will be black so I don't know how to use arrays without including this blank lines or how to write them without them.
x,a,b & d are variable numbers.
a = Sheets("MODULOS").Range("a1048576").End(xlUp).Row
b = Sheets("TODO").Range("a1048576").End(xlUp).Row
For x = 1 To b
Range("Z1").Select
ActiveCell.Offset(x, 0).Select
For i = 1 To (a - 1)
If ActiveCell.Value <> 0 Then
d = Sheets("AGREGADO").Range("a1048576").End(xlUp).Row
Sheets("AGREGADO").Cells(d + 1, 1).Value = Sheets("TODO").Cells(x + 1, 7).Value
Sheets("AGREGADO").Cells(d + 1, 3).Value = Sheets("TODO").Cells(x + 1, 25 + i).Value
Sheets("AGREGADO").Cells(d + 1, 2).Value = Sheets("TODO").Cells(1, 25 + i).Value
Sheets("AGREGADO").Cells(d + 1, 4).Value = Sheets("TODO").Cells(x + 1, 33 + a).Value
End If
ActiveCell.Offset(0, 1).Select
Next i
Next x

There are a few way to make your code faster:
Summary (ranked by importance):
dis-activate Automatic Calculation and screen updating (as in the
comment from Tomjohnriddle)
Avoid the .Select and ActiveCell
Use WITH where possible when working with objects
In your code it would look like this:
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim ra As Range
a = Sheets("MODULOS").Range("a1048576").End(xlUp).Row
b = Sheets("TODO").Range("a1048576").End(xlUp).Row
For x = 1 To b
ra = Cells(1 + x, 26)
With Sheets("AGREGADO")
For i = 1 To (a - 1)
If ra.Value <> 0 Then
d = Sheets("AGREGADO").Range("a1048576").End(xlUp).Row
.Cells(d + 1, 1).Value = Sheets("TODO").Cells(x + 1, 7).Value
.Cells(d + 1, 3).Value = Sheets("TODO").Cells(x + 1, 25 + i).Value
.Cells(d + 1, 2).Value = Sheets("TODO").Cells(1, 25 + i).Value
.Cells(d + 1, 4).Value = Sheets("TODO").Cells(x + 1, 33 + a).Value
End If
ra = Cells(1 + x, 26 + 1)
Next i
Next x
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Align rows to match column

Problem
How can you horizontally align values in separate columns, and apply a dynamic formula? Preemptive thank you for any help or clues! The code pasted below works, in so far as it reaches halfway to the end destination. But how to accomplish the last two objectives?
1) Sum each range
2) Align the ranges horizontally
A sample sheet containing customer id, item and prices. Sales from Monday on the left, Tuesday on the right.
Current results
Desired results
Align cust id on rows A and E, with an associated sum. Notice how each yellow line contains cust id for identification, as well as associated Sum total.
Existing VBA Code
Sub AlignAndMatch()
'backup sheet
ActiveSheet.Copy after:=Sheets(Sheets.Count)
'Insert rows where current cell <> cell above
Dim i, totalrows As Integer
Dim strRange As String
Dim strRange2 As String
'----------------------------------------
'Monday sort table
Range("A2:C65536").Select
Selection.Sort Key1:=Range("A2:C65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Monday insert loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "A" & i
strRange2 = "A" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 1), Cells(i + 2, 3)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Monday footer row loop
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("A" & i).Value) And Not IsEmpty(Range("A" & i + 1).Value) Then
Range("A" & i).Value = Range("A" & i + 1).Value
Range("B" & i).Value = "Sum"
End If
Loop
'----------------------------------------
'Tuesday sort table
Range("E2:G65536").Select
Selection.Sort Key1:=Range("E2:G65536"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Tuesday insert loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
strRange = "E" & i
strRange2 = "E" & i + 1
If Range(strRange).Text <> Range(strRange2).Text Then
Range(Cells(i + 1, 5), Cells(i + 2, 7)).Insert xlDown 'think cells ~A1:C2 insert
totalrows = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Row
i = i + 2 'for insert 2 rows
End If
Loop
'Tuesday footer row loop
totalrows = ActiveSheet.Range("E65536").End(xlUp).Offset(0, 0).Row
i = 0
Do While i <= totalrows
i = i + 1
If IsEmpty(Range("E" & i).Value) And Not IsEmpty(Range("E" & i + 1).Value) Then
Range("E" & i).Value = Range("E" & i + 1).Value
Range("F" & i).Value = "Sum"
End If
Loop
End Sub

If I needed something like that I might think twice what I want and why: if the original day lists don't come from somehwere, you could put everything into one list and make some pivots...
But. Here's some idea, playing with the arrays again and there's probably work to do, but does this help:
Option Base 1
Sub ReLists()
Dim ListSheet As Worksheet
Dim DayCorners() As Range
Dim Day()
Dim Days As Integer
Dim CustIDs()
Dim CustomerRow() 'for placement in the final list
Dim DayList()
Dim MaxCustIDs As Integer
Dim NewCustID As Boolean
Days = 2
MaxCustIDs = 5
ReDim DayCorners(Days)
ReDim Day(Days)
ReDim CustomerRow(MaxCustIDs + 2)
CustomerRow(1) = 0
ReDim CustIDs(MaxCustIDs)
ReDim DayItems(1, 1)
Set ListSheet = Worksheets("Sheet1")
Set DayCorners(1) = ListSheet.Range("A2")
Set DayCorners(2) = ListSheet.Range("E2")
For d = 1 To Days
With ListSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=DayCorners(d)
.SetRange Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
Day(d) = Range(DayCorners(d), DayCorners(d).End(xlDown).Offset(0, 2))
If UBound(Day(d), 1) > UBound(DayItems, 2) Then
ReDim DayItems(Days, UBound(Day(d)))
End If
Next d
CustIDCount = 0
For d = 1 To Days
For r = 1 To UBound(Day(d), 1)
NewCustID = True
For u = 1 To UBound(CustIDs)
If CustIDs(u) = Day(d)(r, 1) Then NewCustID = False
Next u
If NewCustID Then
CustIDCount = CustIDCount + 1
CustIDs(CustIDCount) = Day(d)(r, 1)
End If
Next r
Next d
With Worksheets.Add(After:=Worksheets(ListSheet.Index))
Set DayCorners(1) = .Range("A2")
Set DayCorners(2) = .Range("E2")
End With
ReDim DayList(Days, CustIDCount, 100, 3)
For d = 1 To Days
For c = 1 To CustIDCount
rc = 1
For r = 1 To UBound(Day(d), 1)
If Day(d)(r, 1) = CustIDs(c) Then
DayList(d, c, rc, 1) = Day(d)(r, 1)
DayList(d, c, rc, 2) = Day(d)(r, 2)
DayList(d, c, rc, 3) = Day(d)(r, 3)
rc = rc + 1
End If
Next r
If CustomerRow(c) + rc + 2 > CustomerRow(c + 1) Then
CustomerRow(c + 1) = CustomerRow(c) + rc + 1
End If
Next c
If CustomerRow(c - 1) + rc + 2 > CustomerRow(c) Then
CustomerRow(c) = CustomerRow(c) + rc
End If
Next d
For d = 1 To Days
With DayCorners(d).Offset(-1, 0).Range("A1:C1")
.Value = Array("cust id", "item", "Price")
'formatting
End With
For c = 1 To CustIDCount
SumFormula = "=SUM(R[1]C:R[" & (CustomerRow(c + 1) - CustomerRow(c) - 1) & "]C)"
With DayCorners(d).Offset(CustomerRow(c), 0).Range("A1:D1")
If Not IsEmpty(DayList(d, c, 1, 1)) Then
.Value = Array(CustIDs(c), "Sum", SumFormula, "")
End If
.Interior.Color = 65535
End With
For rc = 1 To UBound(Day(d), 1)
If IsEmpty(DayList(d, c, rc, 1)) Then Exit For
DayCorners(d).Offset(CustomerRow(c) + rc, 0) = DayList(d, c, rc, 1)
DayCorners(d).Offset(CustomerRow(c) + rc, 1) = DayList(d, c, rc, 2)
DayCorners(d).Offset(CustomerRow(c) + rc, 2) = DayList(d, c, rc, 3)
Next rc
Next c
Next d
End Sub

I believe the solution is to simulate an SQL full outer join, via VBA. I'll start hacking away at it. Should be a fun personal challenge. I'll try to update this answer once I find the final solution.
The direction I'm following is here.

Resources