I am trying to build an array containing ranges using a loop so I can paste it all together to earn some time.
The loop pastes stock name from column L to another sheet. Then, dynamic values generate in range (CA59:CQ59).
I tried transpose function just in case, double loop for manual 2d array,and simpler ranges without luck. My best shot was something like
Sheets("Stocks | Sort").Range("O2:O" & UBound(pool) + 1) = WorksheetFunction.Transpose(pool)
returned one column. Apologize for my lack of knowledge. Any ideas would be highly appreciated. Here is my code :
Sub ForecastAll()
Dim line As Range
Dim pool() As Variant
Dim i As Long
For i = 2 To 133
Sheets("Stocks | Sort").Range("L" & i).Copy (Sheets("Stocks | Synopsis").Range("E3"))
ReDim Preserve pool(i)
pool(i) = Sheets("Stocks | Synopsis").Range("CA59:CQ59").Value
Next i
Sheets("Stocks | Sort").Range("O2:AE133").ClearContents
Sheets("Stocks | Sort").Range("O2:AE133").Value = pool
End Sub
It returns blanks. Thank you for your time in advance.
Made a few changes in your code with explanation. Array populated from Worksheet column or row or table range values is a two dimensional array.
Sub ForecastAll()
Dim pool() As Variant
Dim i As Long
'clearing target range first to fill it with the loop below
Sheets("Stocks | Sort").Range("O2:AE133").ClearContents
For i = 2 To 133
Sheets("Stocks | Sort").Range("L" & i).Copy (Sheets("Stocks | Synopsis").Range("E3"))
ReDim Preserve pool(i)
'pool(i) = Sheets("Stocks | Synopsis").Range("CA59:CQ59").Value
'pool is one dimensional array where in at each iteration you are entering _
'a two dimensional array. Which can be ensured with --
'Debug.Print UBound(pool), Join(Application.Index(pool(i), 1, 0), ",")
'instead of using an array you can directly assign values of one range to another like --
Sheets("Stocks | Sort").Range("O2:AE" & i).Value = Sheets("Stocks | Synopsis").Range("CA59:CQ59").Value
'This method should also work fast as it is not selecting ranges and copying-pasting values _
'If you still want to use array, it should be a 2D array and it can not be populated directly _
'from range and it will need a loop to populate that array
Next i
'Sheets("Stocks | Sort").Range("O2:AE133").ClearContents
'Sheets("Stocks | Sort").Range("O2:AE133").Value = pool
End Sub
Related
I've been trying to think of how to do this and can't quite figure it out. The premise is as follows. I need to filter on COLUMN B, following that I need to use the filtered returned results of COLUMN A to filter all of the results. If that's confusing I tried to 'draw' it out below...
COL A | COL B |
cat | 44 |
cat | 476 |
cat | 19 |
dog | 11 |
dog | 12 |
bird | 44 |
bird | 99 |
bird | 4556 |
So if I filter on Column B for 44 I'll only get the two '44' rows returned (cat | 44 and bird | 44). Instead, I want to somehow get all of the cat rows and all of the bird rows, since 44 was associated with those two 'A' types.
COL A | COL B |
cat | 44 |
cat | 476 |
cat | 19 |
bird | 44 |
bird | 99 |
bird | 4556 |
Have any of you done this before? My idea was initially to copy the unaltered sheet over to a new sheet 2, apply the filter and copy the returned column A results to a new sheet 3, use the returned column A results in sheet 3 to do an autofilter on the sheet2 column A. However, there can be hundreds of filters and this is a pretty manual process in VBA.
I'd be happy to add more detail if needed.
You could avoid the AutoFilter method and Range.SpecialCells method with one or more variant arrays.
Option Explicit
Sub cats_and_birds()
Dim crit As Long
Dim i As Long, j As Long, iCols As Long
Dim arr1 As Variant
Static dict As Object '<~~ faster second time around this way
'create and configure the static dictionary
If dict Is Nothing Then _
Set dict = CreateObject("Scripting.Dictionary")
dict.RemoveAll
dict.CompareMode = vbTextCompare
'number of columns to transfer from column A
iCols = 3
'set filter criteria for column 2 within range
crit = 44
With Worksheets("Sheet1")
'assign raw values
arr1 = .Range(.Cells(2, 1), Cells(.Rows.Count, iCols).End(xlUp)).Value2
'show the data array limits in the Immediate window
'delete this or comment it after the routine works
Debug.Print LBound(arr1, 1) & " to " & UBound(arr1, 1)
Debug.Print LBound(arr1, 2) & " to " & UBound(arr1, 2)
'iterate through the 'rows' of the array and compare column 2
For i = LBound(arr1, 1) To UBound(arr1, 1)
'add/oversrite the pet species as key
If arr1(i, 2) = crit Then _
dict(arr1(i, 1)) = 0
'if pet species in key, transfer information
If dict.exists(arr1(i, 1)) Then
'iterate through the columns backwards to maintain row
For j = UBound(arr1, 2) To LBound(arr1, 2) Step -1
.Cells(.Rows.Count, "Z").End(xlUp).Offset(1, j - 1) = arr1(i, j)
Next j
End If
Next i
End With
End Sub
This would actually be better with two arrays; the second receiving the results and then bulk transferring the information but there is also a (smaller) penalty due to redim'ming the array with preserve (and transposing). For small (<10K) this is probably only marginally longer to process. For <100 rows of filtered information you might not be able to measure the difference without special tools.
Dim'ming the dictionary object as Static shortens the load time the second time around because you do not have to recreate the object. While I prefer to add the Microsoft Scripting Runtime to the Tools ► References and use dim dict as new scripting.dictionary not everyone prefers that so I'll post this with CreateObject and dim dict as static.
You can take this routine as a model: it applies to Sheet1, looks for 44 in column B then shows the rows that match from column A
Sub filterBthenA()
Sheet1.UsedRange.Columns("B").AutoFilter 1, 44 '<-- Filter Sheet1 col B by value 44
Dim cel As Range, dict As Object: Set dict = CreateObject("Scripting.Dictionary")
For Each cel In Sheet1.UsedRange.Columns("A").SpecialCells(xlCellTypeVisible)
dict(cel.Value) = 0
Next
Sheet1.AutoFilterMode = False
Sheet1.UsedRange.Columns("A").AutoFilter 1, dict.Keys, xlFilterValues
End Sub
My function takes in a range, say risk-free interest rates, and produces an array of discount factors. The issue seems to be in the loop, threefold:
(a) calling a fn on an array,
(b) specifying the array points,
(c) using the loop i as a fn parameter.
Is the best way to use a loop around each array(point i), or can the full array be populated by simply calling in a function?
Function CreateDiscArray(RFR_array As Range)
Dim MyArray() As Variant
MyArray = RFR_array
Dim xDimRate As Integer
xDimRate = UBound(MyArray, 1)
Dim TempArray() As Variant
For i = 1 To xDimRate Step 1
TempArray(i, 1) = DiscFact(MyArray(i), i)
Next i
CreateDiscArray() = TempArray()
End Function
.
Function DiscFact(Rate, Tenor)
If Tenor < 1 Then DiscFact = (1 + Tenor * Rate)
If Tenor >= 1 Then DiscFact = (1 + Rate) ^ (-Tenor)
End Function
i.e. is it possible to just call, without the loop:
CreateDiscArray = DiscFact(MyArray(,1), 1 to xDimRate)
There are some problems with your original code
You're not using Option Explicit, so you don't know that i is undeclared.
You're not dimensioning the TempArray, so your code can't assign to its indexes.
You're referencing myArray(i) which will fail as there are 2 dimensions, so you must use myArray(i,1).
You're using the i counter (which is 1-based) as the tenor. That's a poor design choice as your tenors won't always be consistent lengths, and you can expect to have many short-dated tenors. Furthermore, that's a bug, because i >= 1 will always be TRUE
So, to make your original functions workable code:
Option Explicit
Function CreateDiscArray(RFR_array As Range)
Dim MyArray() As Variant
MyArray = RFR_array.Value
Dim xDimRate As Integer
xDimRate = UBound(MyArray, 1)
ReDim TempArray(LBound(MyArray) To UBound(MyArray), LBound(MyArray, 2) To UBound(MyArray, 2)) As Variant
Dim i As Long
For i = 1 To xDimRate Step 1
TempArray(i, 1) = DiscFact(MyArray(i, 1), i)
Next i
CreateDiscArray = TempArray
End Function
Function DiscFact(Rate, Tenor)
'BUG: Tenor will always be >= 1
If Tenor < 1 Then DiscFact = (1 + Tenor * Rate)
If Tenor >= 1 Then DiscFact = (1 + Rate) ^ (-Tenor)
End Function
But that's not your question. As others have pointed out, VBA doesn't support anything natively, but you're using Excel, so you do have some options:
Firstly, let's fix the Tenor bug by adding a range of tenors in addition to the rates. Tenors are in A1:A3 and rates are in B1:B3. We can use an array formula in C1:C3 as =IF(A1:A3<1,1+A1:A3*B1:B3,(1+B1:B3)^(-A1:A3))
A | B | C
--+-----|------|-------------------------------------------------
1 | .5 | 99 | {=IF(A1:A3<1,1+A1:A3*B1:B3,(1+B1:B3)^(-A1:A3))}
2 | 1 | 97 |
3 | 2 | 95 |
And, if you name named ranges as Tenor and Rate, you can redefine the array formula as =IF(Tenor<1,1+Tenor*Rate,(1+Rate)^(-Tenor))
If you really want this solution to be in VBA, you'll need to change your function signature to accept tenor and rate ranges, and then use Application.Evaluate along with a constructed formula, to get an array of the results.
With a clumsy solution that doesn't care for sheets or workbooks:
Public Function DiscFactor(rates As Range, tenors As Range) As Variant
Dim Rate As String
Dim Tenor As String
Rate = rates.Address
Tenor = tenors.Address
DiscFactor = Application.Evaluate("=IF(" & Tenor & "<1,1+" & Tenor & "*" & Rate & ",(1+" & Rate & ")^(-" & Tenor & "))")
End Function
I have the below table in Excel (TABLE).
I am trying to cycle through the table and story in an array (CODE).
Then cycle through the array and produce a unique output based on ID (OUTPUT).
I have provided the code I have but am having trouble determine the best way to loop through the array where the ID is the same - ie I want to group array outputs by ID.
TABLE
| ID | Name | Value |
---------------------
| 01 | John | Value |
| 01 | Sam | Value |
| 02 | Luke | Value |
| 03 | Jack | Value |
| 04 | Rob | Value |
| 04 | Bob | Value |
OUTPUT
01 - John, Sam
02 - Luke
03 - Jack
04 - Rob, Bob
CODE
'Store Array
For row = 2 to 6
MyArray(i,0) = Cells(row,1).value
MyArray(i,1) = Cells(row,2).value
MyArray(i,2) = Cells(row,3).calue
next row
'Output Array
For a = Lbound(MyArray) to Ubound(MyArray)
???
Next a
I do not know whether I use if/then/else statements or another loop to achieve this?
Say we begin with:
and we want an output as in your post. Running this:
Sub Macro1()
Range("A2:A22").Copy Range("E1")
ActiveSheet.Range("$E$1:$E$21").RemoveDuplicates Columns:=1, Header:=xlNo
For Each r In Range("E1:E22")
v = r.Value
If v = "" Then Exit Sub
For Each rr In Range("A2:A22")
vv = rr.Value
If v = vv Then
If r.Offset(0, 1).Value = "" Then
r.Offset(0, 1).Value = rr.Offset(0, 1).Value
Else
r.Offset(0, 1).Value = r.Offset(0, 1).Value & "," & rr.Offset(0, 1).Value
End If
End If
Next rr
Next r
End Sub
will produce:
I'll post my version which uses Dictionary.
Sub Test()
Dim sh As Worksheet: Set sh = Sheets("Sheet1") ' I try to always be explicit
With sh
Dim lr As Long, RawArr
lr = .Range("A" & .Rows.Count).End(xlUp).Row
RawArr = .Range("A2:C" & lr) ' pass to array
End With
Dim i As Long, idkey As String, itm As String
' Use Dictionary to handle duplicates and concatenate values
With CreateObject("Scripting.Dictionary")
For i = LBound(RawArr, 1) To UBound(RawArr, 1)
idkey = RawArr(i, 1): itm = RawArr(i, 2)
If Not .Exists(idkey) Then
.Add idkey, idkey & " - " & itm
Else
.Item(idkey) = .Item(idkey) & ", " & itm
End If
Next
' Return values to worksheet
' Use below if you're working on small data set
' If not, replace below with a loop - also posted
sh.Range("E1:E" & .Count) = Application.Transpose(.Items)
End With
End Sub
Above is pretty straight forward with the output exactly as you described.
At the last part, we used Application.Transpose to transfer the values back to the worksheet.
Take note that it has limitations as to how large it can handle like 65k rows.
As long as your data does not go near that value, then you should be ok.
If however you have a lot of data, then you'll have to use another loop to get the values (like manually transposing your data).
Dim key, fArr, n As Long: n = 1
ReDim fArr(1 To .Count, 1 To 2) ' use a 2D array
For Each key In .Keys
fArr(n, 1) = .Item(key)
n = n + 1
Next
sh.Range("E1:E" & .Count) = fArr
Note: I assumed that your ID's are strings (e.g.01) and not numbers formatted as "00". If that is the case, then you'll need to format it first before you use it as idkey like below to get your desired output.
idkey = Format(RawArr(i, 1), "00")
I'm new to VBA and I'm stuck..
I have a table with workers and the amount of time they have been working. I want to insert all the workers into an array with the total time they have been working and then print out them into another sheet.
The problem is that I don't know if it's even possible to insert these values together into an array.. Right now I have hard-coded the names into my code and use If-statements to add hours to the right name but that will be a problem if I add more workers to the table (because then I need to add those names into the code too). I don't want the code to know the names or how many workers there are before it runs.
I want the print-out to be like:
Steve | 13
Emma | 2
Andy | 3
Jeff | 12
Appreciate any help!
use this or something like this:
Sub test()
Dim Dic As Object, oCell As Range, i&, y%, key As Variant
Set Dic = CreateObject("Scripting.Dictionary")
y = 1: i = Cells(Rows.Count, "A").End(xlUp).Row
For Each oCell In Range("A2:A" & i)
If Not Dic.exists(oCell.Value) Then
Dic.Add oCell.Value, WorksheetFunction.SumIf(Range("A2:A" & i), oCell.Value, Range("B2:B" & i))
End If
Next
For Each key In Dic
Debug.Print key, Dic(key)
Next
End Sub
here the screenshot
Very simple way:
Function GetTable(r As Range) As Variant
GetTable = r.Value
End Function
Sub main()
Dim Table As Variant
Table = GetTable(ActiveSheet.Range("A2:B6")) 'Supply the range of your workers.
For i = 1 To UBound(Table, 1)
Sum = Sum + Table(i, 2)
Next
MsgBox (Sum)
End Sub
ouput:
Just use a PivotTable and if necessary have the PivotTable automatically refresh when the sheet is clicked.
I'm a little bit familiar with VBA Excel 2013. My problem now is, that I need to sum the values where specific Strings are available.
I need to calculate within a column only the values where a lookup is true.
My table looks like:
9 | AD,DCO,PD
5 | AD
5 | PD
15 | PD
So the sum for AD would be 14 or DCO would be 9 or PD would be 29 an therefore the result table have to look like this:
AD | DCO | PD
—–—–—–—–—–––—–
14 | 9 | 29
Can anybody help me?
Forget VBA. Sumproduct solves this perfectly.
I'm assuming that your commas separate cells, so Column A has the numbers, then columns B-D have the letters. If they do not, you can always use the Text to Columns function in excel (look under the Data tab) to make this so.
Put the following function where you wnat the answer (say, B10):
=SUMPRODUCT(($A$1:$A$4) * ($B$1:$D$4 = $A$10))
You can then type in cell A10 the code letter and it will sum up column A, where columns B-D contain that text.
If you want to display all text options, you can make a list of them (say A10 = AD, A11 = DCO, A12 = PD), then in B10 put the same formula as above but remove the $ from in front of the number (so it reads $A10). You can then drag it down and it will tally up for each of the values in A10-A13 and display the results in B10 - B13.
If I have correctly interpreted your sample data into a pseudo-table then the native SUMIF function will conditionally sum the numbers in column A using a wildcard criteria against column B. Example in D2 (as the image below) would be =SUMIF($B$1:$B$4,"*"&D$1&"*",$A$1:$A$4).
Fill or copy right as necessary. The caution is that wildcards may make false positives when the criteria closely resembles other values. This is not the case with your sample data.
Problem Solved, but do you have any suggestion to speed up the code?
Sub Calculate()
Dim Dict As Object
Dim i As Long
Dim e As Long
Set Dict = CreateObject("Scripting.Dictionary")
Dim b, m As Long
Dim a As Long
Dim c As Variant
Dim j As Long
Dim sum_Dict As Variant
Dim column_Dict As Variant
i = 1
e = 16
a = i
a = a - 2
For i = i To e
For Each sum_Dict In Range("A" & i & ":" & "A" & e) 'Spalte V = Price
If sum_Dict = "" Then
i = i + 1
Else
For Each c In Range("B" & i & ":F" & i) 'All Columns from B til F
' iterating over the array
For j = LBound(column_Dict) To UBound(column_Dict)
' assigning the separated values to columns
b = CDbl(sum_Dict) 'convert to double
c = CStr(c) 'convert to string
If Dict.Exists(c) Then 'check if key exists
Dict.Item(c) = Dict.Item(c) + b 'if key exists sum the items
Else 'if the key does not exist create it
Dict.Add Key:=c, Item:=b
End If
Next j
Next c
i = i + 1
'extract keys into variant array
'Debug.Print "Array of Keys and items"
For m = 0 To Dict.Count - 1
'Debug.Print Dict.Keys()(m), Dict.Items()(m)
Next m
'Debug.Print Dict.Count & " Items in Dictionary"
End If
Next sum_Dict
Next
'-- output to sheet using first 1D Array
Range("H" & a + 2).Resize(1, _
UBound(Application.Transpose(Dict.Keys()))) = Dict.Keys()
'-- output to sheet using dictionary
Range("H" & a + 3).Resize(1, _
UBound(Application.Transpose(Dict.Items()))) = Dict.Items()
Dict.RemoveAll ' empty dictionary
End Sub