Writing rudimentary VBA to populate a 2 dimensional array filled with two sums one consisting of the odd columns the other is the sum of the even columns, totaled over a variable amount of rows stored in another array. the two dimensional array then prints on a seperate worksheet. I wrote code which succesfully completed this task on two other worksheets in the same file with slightly different sized arrays, but it populates the destination range with zeros when adjusted for the new input and output.
code in question:
Sub dad()
Dim i As Integer, j As Integer, units As Double, value As Double, mr(1 To 655, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1010").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1010totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 655
mr(i, 1) = Worksheets("1010totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 655
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 655
For j = 2 To 3
Worksheets("1010totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
Original code that works on the other worksheets:
Sub ded()
Dim i As Integer, j As Integer, units As Double, value As Double, n As Integer, mr(1 To 756, 1 To 3) As Double, u As Integer, here As Range
Dim thisone As String, there As Range
thisone = Worksheets("MB52 for 1030").Cells(1, 1).Address
Set here = Range(thisone)
MsgBox (here(1, 1).Address)
thisone = Worksheets("1030totals").Cells(1, 1).Address
Set there = Range(thisone)
MsgBox (there(1, 1).Address)
For i = 1 To 756
mr(i, 1) = Worksheets("1030totals").Cells(i + 1, 4).value
Next i
MsgBox ("array made")
i = 1
u = 1
MsgBox (i & " " & u)
For i = 1 To 756
For j = 1 To mr(i, 1)
u = u + 1
units = here(u, 6) + here(u, 9) + here(u, 11).value + here(u, 13) + here(u, 15) + here(u, 17)
value = here(u, 8) + here(u, 10) + here(u, 12).value + here(u, 14) + here(u, 16) + here(u, 18)
Next j
mr(i, 2) = units
mr(i, 3) = value
Next i
For i = 1 To 756
For j = 2 To 3
Worksheets("1030totals").Cells(i + 1, j).value = mr(i, j)
Next j
Next i
End Sub
Related
There are several constants TAX1, TAX2, TAX3,...,TAX_y Further array (arrSorted) of data, prices,..
I need compare value arrSorted(allRow, 8) with TAX and make some sums.
But how increment end number of constant TAX?
for i = LBound... to UBound...
for y = 1 to 5
if arrSorted(i,8) = TAX & y then 'i dont know how TAX & y...
' SUMS HERE
end if
next y
next i
I now have this recurring code (That's not very nice):
Function prepareData(arrSorted() As Variant)
Dim qi As Integer
Dim qy As Integer
Dim sumPrice(0 To 4, 0 To 5) As Variant
For qi = LBound(arrSorted(), 1) To UBound(arrSorted(), 1)
Select Case arrSorted(qi, 8)
Case Is = TAX1
For qy = LBound(sumPrice, 2) To UBound(sumPrice, 2)
sumPrice(0, qy) = sumPrice(0, qy) + arrSorted(qi, qy + 4)
Next qy
Case Is = TAX2
For qy = LBound(sumPrice, 2) To UBound(sumPrice, 2)
sumPrice(1, qy) = sumPrice(1, qy) + arrSorted(qi, qy + 4)
Next qy
Case Is = TAX3
For qy = LBound(sumPrice, 2) To UBound(sumPrice, 2)
sumPrice(2, qy) = sumPrice(2, qy) + arrSorted(qi, qy + 4)
Next qy
Case Is = TAX4
For qy = LBound(sumPrice, 2) To UBound(sumPrice, 2)
sumPrice(3, qy) = sumPrice(3, qy) + arrSorted(qi, qy + 4)
Next qy
Case Is = TAX5
For qy = LBound(sumPrice, 2) To UBound(sumPrice, 2)
sumPrice(4, qy) = sumPrice(4, qy) + arrSorted(qi, qy + 4)
Next qy
Case Else
MsgBox "Alert!", vbCritical
End Select
Next qi
End Function
You cant dynamically adjust variable names inside the code module during code execution.
But what you can do is put all your constants into an array and loop through the array of constants until you find the one you're looking for.
Or you could put all the constants into a dictionary with their variable name as the key. So MyDictionary("TAX1") = TAX1 is true. In your code you could do If arrSorted(i,8) = MyDictionary("TAX" & y).
Here's an example of how to create a dictionary object:
Dim MyDictionary As Object
Set MyDictionary = CreateObject("Scripting.Dictionary")
'Putting the constants inside with their variable name as the key
MyDictionary.Add Key:="TAX1", Item:=TAX1
MyDictionary.Add Key:="TAX2", Item:=TAX2
MyDictionary.Add Key:="TAX3", Item:=TAX3
MyDictionary.Add Key:="TAX4", Item:=TAX4
MyDictionary.Add Key:="TAX5", Item:=TAX5
MyDictionary.Add Key:="TAX6", Item:=TAX6
MyDictionary.Add Key:="TAX7", Item:=TAX7
MyDictionary.Add Key:="TAX8", Item:=TAX8
'How to retrieve their values
MsgBox MyDictionary("TAX8")
Use a dictionary and the exists method in place of Select Case.
Function prepareData(arrSorted() As Variant)
Const TAX1 = 5
Const TAX2 = 10
Const TAX3 = 15
Const TAX4 = 20
Const TAX5 = 25
Dim qi As Integer, qy As Integer, key As String, i As Integer
Dim sumPrice(0 To 4, 0 To 5) As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Add CStr(TAX1), 0
dict.Add CStr(TAX2), 1
dict.Add CStr(TAX3), 2
dict.Add CStr(TAX4), 3
dict.Add CStr(TAX5), 4
For qi = LBound(arrSorted(), 1) To UBound(arrSorted(), 1)
key = Trim(arrSorted(qi, 8))
If dict.exists(key) Then
i = dict(key)
For qy = LBound(sumPrice, 2) To UBound(sumPrice, 2)
sumPrice(i, qy) = sumPrice(i, qy) + arrSorted(qi, qy + 4)
Next qy
Else
MsgBox "Alert! Row " & qi, vbCritical, "Value=" & key
End If
Next qi
' result
Sheet2.Range("A1:F5").Value2 = sumPrice
End Function
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
this is part of my code that i am working with and I have one problem. I have array with values (masyvas) and i started new loop to find other values by using masyvas(i,1) values and after that i need that new values would be printed in masyvas(i,2) and i need to group them. It need to look like this:
991988 Gaz.duon.sk"Giros"gaiv.g.1,5L 5_PETØFLAT1,5
PALINK
117388 Silp.gaz.nat.min.v"Tiche'1,5L 5_PETØFLAT1,5
PALINK
RIMI LIETUVA
ŠIAULIŲ TARA
111388 Gaz.nat.min.v"Tiche" 1,5L pet 5_PETØFLAT1,5
PALINK
AIBĖS LOGISTIKA
AIBĖS LOGISTIKA
RIMI LIETUVA
ŠIAULIŲ TARA
How it looks now from marked 1 it goes wrong
Data sheet where i get array values
Here is part of my code where i have this problem now it prints new values next to masyvas(i,2) but not below as I need.
lastrow2 = Sheets("lapas").Cells(Rows.Count, 1).End(xlUp).Row
rub = lastrow2
cub = 3
ReDim masyvas(1 To rub, 1 To cub)
For i = 1 To rub
For j = 1 To cub
masyvas(i, j) = Sheets("lapas").Cells(i, j).Value 'array gets values from filtered data in AKCIJOS sheet
Next
Next
Sheets("lapas").Range("A1:C100").Clear
For i = 1 To rub Step 1
Set rng2 = grafikas.Cells(6 + h, 2)
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
grafikas.Cells(7 + r, 2).EntireRow.Select
Selection.Insert Shift:=xlDown
grafikas.Cells(7 + r, 3) = akcijos.Cells(m, 3)
r = r + 1
h = r
End If
End If
Next m
For j = 1 To cub Step 1
rng2.Offset(i - 1, j - 1).Value = masyvas(i, j)
Next
Next
You didn't provide any screenshot of your data, so it's hard to say what exactly is your problem and desired output, but try the code below. I marked changed lines.
For i = 1 To rub
prekeskodas = masyvas(i, 1)
For m = 2 To lastrow
If akcijos.Cells(m, 8) >= laikas And akcijos.Cells(m, 8) <= laikas2 Then
If prekeskodas = akcijos.Cells(m, 4) Then
'masyvas(i, 2) = masyvas(i, 2) & akcijos.Cells(m, 3)
masyvas(i, m) = masyvas(i, m) & akcijos.Cells(m, 3) '<------
End If
End If
Next
For j = 1 To cub
rng2.Offset(j - 1, i - 1).Value = masyvas(i, j) '<-----
Next
Next
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.
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