Split multidimensional array and then slice it [closed] - excel

Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 8 years ago.
Improve this question
I have a column of paths:
C:\Series1\Season1\Ep1
C:\Series1\Season2\Ep1
C:\Series2\Season1\Ep1
C:\Series2\Season2\Ep1
C:\Series3\Season1\Ep1
I now want to split the array into a multidimensional one, so it looks like this in the end:
+---+----+---------+---------+-----+
| | 1 | 2 | 3 | 4 |
+---+----+---------+---------+-----+
| 1 | C: | Series1 | Season1 | Ep1 |
| 2 | C: | Series1 | Season2 | Ep1 |
| 3 | C: | Series2 | Season1 | Ep1 |
| 4 | C: | Series2 | Season2 | Ep1 |
| 5 | C: | Series3 | Season1 | Ep1 |
+---+----+---------+---------+-----+
I then have a function called unique(checkArray) that checks the number of unique values in an array. I want to have this function check every column 1 by 1.
Debug.Print uniqueValues(Column1)
Debug.Print uniqueValues(Column2)
Debug.Print uniqueValues(Column3)
Debug.Print uniqueValues(Column4)
How do I get the array into that formation and then checked?

Sub SplitMe()
Dim values As Variant
values = ActiveSheet.Range("A1:A5")
If Not IsArray(values) Then _
Exit Sub
Dim r As Integer
Dim parts As Variant
Dim partsMaxLenght As Integer
Dim splitted As Variant
ReDim splitted(LBound(values) To UBound(values))
For r = LBound(values) To UBound(values)
parts = VBA.Split(values(r, 1), "\")
' Split always returns zero based array so parts is zero based array
If UBound(parts) + 1 > partsMaxLenght Then _
partsMaxLenght = UBound(parts) + 1
splitted(r) = parts
Next r
Dim matrix As Variant
Dim c As Integer
ReDim matrix(LBound(splitted) To partsMaxLenght, LBound(splitted) To UBound(splitted))
For r = LBound(splitted) To UBound(splitted)
parts = splitted(r)
For c = 0 To UBound(parts)
matrix(c + 1, r) = parts(c)
Next c
Next r
uniqueValues matrix
End Sub
Private Sub uniqueValues(matrix As Variant)
Dim r, c
For r = LBound(matrix, 1) To UBound(matrix, 1)
For c = LBound(matrix, 2) To UBound(matrix, 2)
Debug.Print matrix(r, c)
Next c
Next r
End Sub
Output:
C:
D:
E:
F:
H:
etc.

You would reference the array the same way you'd reference fields in a table. Like tables, arrays are also zero-based (meaning, the first column is referenced as 0 instead of 1). So, if your array is called MyArray, you would be doing something like:
Debug.Print MyArray(0)
Debug.Print MyArray(1)
Debug.Print MyArray(2)
Debug.Print MyArray(3)
Don't forget that you first have to Dim your array. If you know how many columns it has, you can explicitly Dim it like so:
Dim MyArray(0 to 3) As String
If not, you can leave it open-ended like so:
Dim MyArray() As String
You would have to loop through your array to get data from a specific line number, I don't think you can reference it any other way.

Use the Split function to split your entries, like this
Dim episodes() As Variant
ReDim episodes(numEntries - 1) As Variant
For i = 0 to numEntries - 1
episodes(i) = Split(paths(i), "/")
Next i
Debug.Print episodes(1)(1) ' = Series1
Debug.Print episodes(1)(2) ' = Season2
After that, ensuring duplicates should be as easy as looping over each item in the array.
Alternately, if you're just looking to find duplicates for the entire path, just create a collection object and load the item into the collection using the path as the key. If the item has already been loaded the collection will throw an error.
On Error Goto Catch
Dim episodes as Collection
Set episodes = New Collection
For i = 0 to numEntries - 1
episodes.add paths(i), paths(i)
Next i
Exit Sub
Catch:
'duplicate found

Related

Is there a way to create a Python or VBA script for Excel to merge rows of data by their list numbering order (their order in an outline)?

I am currently starting a project where I need to manage contractual requirements for a large-scale engineering and construction contract.
Unfortunately, all of the identified project requirements were delivered via PDF (there are thousands of Reqs...). I’ve since taken these PDFs and converted them to spreadsheets in Excel. I will eventually use .CSV files to import these into our RM Tool.
My problem is that all of the project requirement PDFs were written for ease of readability- not so much for use in spreadsheet form. Every section is written like a numbered list, which is fine, but I do not need to have the requirements decomposed to the level they are.
I need to take the “outline, list-numbered format” of the docs and be able to have the child requirements (sub items in example below), combined (concatenated) into rows based on their sections and list numbering.
Right now, I am doing all of this merging of rows by hand, but I don't see how I can get the task done quick enough.
Here is an example of how the PDFs look from the client:
Section 1-1.1: General
A. The contractor shall do “this”, then “that”.
“This” will cost less than this much money
“That” will cost less than this amount of money
a. If “that” costs more, it should not be added
b. Another option is “this”
B. The contractor shall name “this”...
The name should use proper grammar
C. The contractor shall complete work before 2022
Section 1-2.1: Materials
A. The contractor shall use these three materials:
Aluminum
Steel
Cement
a. Cement should be gray only
__i. Gray coloring must be this shade
__ii. Gray cement must not lose coloring
b. Cement should be mixed on-site
Section 1-2.2: Material Suppliers
A. Aluminum must be supplied by “ABC, Inc”
B. Steel must be supplied by “DEF, Inc”
C. Cement must be supplied by "GHI, Inc"
Table 1-1: Supplier Contact Info
[TABLE HERE]
Section 1-3.1: Landscaping
...
Here is how the Excel docs look in their main state. Note that we have added attributes to support each requirement item row, so there is not just one or two columns in these sheets:
CURRENT EXAMPLE IMAGE
| [Col A] Requirement List Item | [Col B] Requirement Text |
|-------------------------------|-------------------------------------------------|
| Section 1-1.1 | General |
| A. | The contractor shall do “this”, then “that”. |
| 1 | “This” will cost less than this much money |
| 2 | “That” will cost less than this amount of money |
| a. | If “that” costs more, it should not be added |
| b. | Another option is “this” |
| B. | The contractor shall name “this”... |
| 1 | The name should use proper grammar |
| C. | The contractor shall complete work before 2022 |
| Section 1-2.1 | Materials |
| A. | The contractor shall use these three materials: |
| 1 | Aluminum |
| 2 | Steel |
| 3 | Cement |
| a. | Cement should be gray only |
| i. | Gray coloring must be this shade |
| ii. | Gray cement must not lose coloring |
| b. | Cement should be mixed on-site |
| Section 1-2.2 | Material Suppliers |
| A. | Aluminum must be supplied by “ABC, Inc” |
| B. | Steel must be supplied by “DEF, Inc” |
| C. | Cement must be supplied by "GHI, Inc" |
| Table 1-1 | [Table Here] |
| Section 1-3.1 | Landscaping |
| ... | ... |
As you can see, the current format I have just has each line item in a different row, with no clear indication of whether or not it's a parent or child item. It is easy to tell what items exist within each Section, but we need to determine what items are included for each top level (Level 1 being A, B, C, D items).
Finally, here is what we’re hoping to have for an end result. We want to just have the rows of data sorted by their section number and then their top-level child requirements (Levels A,B,C,D in this example):
FINAL EXAMPLE IMAGE
Does anyone have an idea on how to create a Python script to handle this task? I have been trying to figure this out for a week and a half, but I can’t seem to find the right functions to use. I have looked up Excel functions/forumlas, and different uses for Concat and Merge/TextJoin.
TLDR: I want to take the Project Requirement data given to us in numbered list format (from PDFs) and organize it in Excel spreadsheets to group/concate/merge rows only based on what the section and top-level sub-item data is (Please see examples above).
Thank you for any help/advice. I am really interested in learning script-writing to make my job easier, I just am at a loss as to where to start with something like this.
Here is the VBA code that is unable to complete the task. It seems to break after 2-3 sections of data:
Sub GroupLists()
Dim startRow As Integer
Dim lastRow As Integer
Dim outputRow As Integer
outputRow = 0
Dim outputStr As String
Dim col_list As Integer
Dim col_list_str As String
Dim col_content As Integer
Dim col_content_str As String
Dim currentList As String
Dim i As Integer
Dim j As Integer
Dim parseSheet As String
Dim outputSheet As String
Dim startList As Boolean
startList = False
Dim indent As Integer
indent = 0
'regex patterns
Dim regexObject As RegExp
Set regexObject = New RegExp
Dim pattern_listHeader As String
Dim pattern_listUpAlpha As String
Dim pattern_listLowAlpha As String
Dim pattern_listNum As String
pattern_listHeader = "[\d]-"
pattern_listUpAlpha = "[A-Z]"
pattern_listLowAlpha = "[a-z]"
'configurable variables
parseSheet = "Input"
outputSheet = "Output"
col_list = 2
col_content = 3
outputRow = 1
startRow = Worksheets("Control").Cells(2, 1).Value
lastRow = Worksheets("Control").Cells(2, 2).Value
For i = startRow To lastRow
col_list_str = Worksheets(parseSheet).Cells(i, col_list).Value
col_content_str = Worksheets(parseSheet).Cells(i, col_content).Value
With regexObject
.Pattern = "^[\d]-"
End With
If regexObject.Test(col_list_str) = True Then
If startList = True Then
'write output to row, then write current row to output row
Worksheets(outputSheet).Cells(outputRow, 1).Value = outputStr
outputRow = outputRow + 1
End If
outputStr = Worksheets(parseSheet).Cells(i, col_content)
'write to row
Worksheets(outputSheet).Cells(outputRow, 1).Value = outputStr
'increment row
outputRow = outputRow + 1
outputStr = ""
startList = False
End If
With regexObject
.Pattern = "^[A-Z]."
End With
If regexObject.Test(col_list_str) = True Then
If startList = True Then
startList = False
Else
startList = True
End If
outputStr = outputStr & col_list_str & col_content_str & vbNewLine
'outputRow = outputRow + 1
End If
If startList = True Then
With regexObject
.Pattern = "^[a-z]."
End With
If regexObject.Test(col_list_str) = True Then
'indent = 1
outputStr = outputStr & col_list_str & col_content_str & vbNewLine
'outputRow = outputRow + 1
End If
With regexObject
.Pattern = "^[0-9]."
End With
If regexObject.Test(col_list_str) = True Then
'indent = indent + 1
outputStr = outputStr & col_list_str & col_content_str & vbNewLine
'outputRow = outputRow + 1
End If
End If
Next i
If startList = True Then
Worksheets(outputSheet).Cells(outputRow, 1).Value = outputStr
End If
End Sub
Typical duplication shown below. In response to comments for #Dy.Lee.
As I wrote so many comments I decided to post a guide answer and delete my comments i.e. provide some pointers to one possible solution.
Logic:
I would read everything into an array and loop the rows of that. Apply logic that processes rows according to rules e.g. does it start with Section.....
is it a Capital letter at start of col 1 of array... is it a number...
A nice idea is probably to use helper functions. E.g.
A helper function which grabs the lines upper case after Section down to next upper case (stop before) and returns that text (as an array).
Then pass that function return value to another function which handles the alphanumeric based indentation levels (using appropriate Chr$()) etc
Another function call to concatenate those values into single string - which will be the value associated with a given key.
Then update the dictionary with the key value pair.
This way you can create a dictionary of key A: associated text from last of helper function calls and write out to sheet at end.
You will need additional logic for tables etc. Tables would be added to dictionary as an array with key being value from first column
At the end you can loop and write out to sheet. I think caution is needed with writing out tables as they may take more than one row. In that case, have an additional helper function that calculates last populated row anywhere in sheet (or target column range) and ensure next key:value pair is written out to after the table by adding + 1 to last populated row number.
When you write out the table, you will need to test the dictionary key for it containing 'table', or that its value is an array; you will need to resize the target cell to the size of the array e.g. if dict(key) = results then targetCell.Resize(UBound(results, 1), UBound(results, 2)) = results
Think about how any hyperlinks (where friendly name different from destination)| additional metadata will be passed around.
Supplying sample data:
I think I would suggest you use a markdown table generator to supply the current data (the input data) to save people time having to write out their own data. You can paste from Excel into markdown generator, press generate table, then copy to clipboard that table, use edit to insert into question. Highlight table just pasted in and press Ctrl + K to indent properly.
Regex:
Regex is not required from what I can see. Data resides in separate cells in source.
Tagging:
I think remove the python tag unless you have python code to add.
Resources:
https://bettersolutions.com/vba/strings-characters/builtin-constants.htm
Some useful constants regarding indentation
| VBA.Constants | Chr | Comments |
|---------------|-----------------------|----------------------------------------------------------------------------------------------------------------|
| vbCr | Chr(13) | Carriage return character |
| vbLf | Chr(10) | Linefeed character |
| vbCrLf | Chr(13) + Chr(10) | Carriage return - linefeed combination |
| vbNewLine | Chr(13) + Chr(10) | New line character |
| vbNullChar | Chr(0) | Character having a value of 0. |
| vbNullString | String having value 0 | Not the same as a zero-length string (""); used for calling external procedures. Cannot be passed to any DLL's |
| vbTab | Chr(9) | Tab character |
| vbBack | Chr(8) | Backspace character |
| vbFormFeed | Chr(12) | Word VBA Manual - manual page break ? |
| vbVerticalTab | Chr(11) | Word VBA Manual - manual line break (Shift + Enter) |
Dictionaries -
https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/dictionary-object
http://www.snb-vba.eu/VBA_Dictionary_en.html
Passing and returning arrays - http://www.cpearson.com/excel/passingandreturningarrays.htm
Arrays and ranges - http://www.cpearson.com/excel/ArraysAndRanges.aspx
Typed functions - What's the difference between Trim() and Trim$() in VBA? re: Chr$ v Chr.
Alternative approach:
If working with arrays and dictionary (which should be quick) doesn't work for you, the logic regarding how to separate out your chunks/indentations can still apply in a loop over the actual rows in the sheet. You would need to keep track however of where you are writing out to based on last row in destination range (you can use a different last row helper function and pass in the column to use to determine the last populated row in).
Try,
Sub setGroup()
Dim Ws As Worksheet, toWs As Worksheet
Dim vDB As Variant, vR() As Variant
Dim vResult(), vRow()
Dim s As String, s2 As String
Dim sName As String
Dim i As Long, j As Long, r As Long
Dim cnt As Long, n As Long, k As Integer
Dim st As Long, et As Long
Set Ws = Sheets(1) 'Data Sheet
Set toWs = Sheets(2) 'Result Sheet
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
ReDim vRow(1 To r)
For i = 2 To r
s = vDB(i, 1)
If s Like "[A-Z].*" Or s Like "Section*" Or s Like "Table*" Then
n = n + 1
vRow(n) = i
End If
Next i
If vRow(n) < r Then
ReDim Preserve vRow(1 To n + 1)
vRow(n + 1) = r
Else
ReDim Preserve vRow(1 To n)
End If
cnt = UBound(vRow)
ReDim vResult(1 To r, 1 To 2)
n = 0
sName = vDB(1, 1)
For j = 1 To cnt - 1
k = 0
Erase vR
st = vRow(j)
If j = cnt - 1 Then
et = vRow(j + 1)
Else
et = vRow(j + 1) - 1
End If
For i = st To et
s = vDB(i, 1)
s2 = ""
'*** Set spacing for each group
If s Like "[A-Z].*" Or s Like "Section*" Or s Like "Table*" Then
Else
If IsNumeric(s) Then
s2 = Space(4) & s & "."
ElseIf s Like "[a-z].*" And Not (s Like "i*") Then
s2 = Space(8) & s
Else
s2 = Space(12) & s
End If
End If
'Collect data according to conditions.
If s Like "Section*" Then
n = n + 1
vResult(n, 1) = vDB(i, 1)
vResult(n, 2) = vDB(i, 2)
ElseIf s Like "[A-Z].*" Then
n = n + 1
k = k + 1
sName = s
ReDim Preserve vR(1 To k)
vR(k) = vDB(i, 2)
ElseIf s Like "Table*" Then
n = n + 2
vResult(n - 1, 1) = vDB(i, 1)
vResult(n - 1, 2) = "Supplier Contct Infor"
vResult(n, 2) = vDB(i, 2)
Else
k = k + 1
ReDim Preserve vR(1 To k)
vR(k) = s2 & " " & vDB(i, 2)
End If
Next i
If k Then
vResult(n, 1) = sName
vResult(n, 2) = Join(vR, vbCrLf)
Else
End If
Next j
With toWs
.Cells.Clear
.Range("a1").Resize(n, 2) = vResult
End With
End Sub
Data Image
Result Image

Excel function to return sum of corresponding items in array

I am pretty new to Excel and VBA, but I was trying to make a function that would provide this result.
A B
-----------
1 | A | 1 |
2 | B | 2 | =TotalItems("A", A1:A4, B1:B4)
3 | C | 3 | =5
4 | A | 4 |
-----------
It searches through an array to find all occurrences, and then sums up the corresponding values in another array. I'm not sure if there is already a function to do this, but I tried creating one. Here's the code:
Function TotalItems(itemToFind, itemsToReference, resultArr)
Dim i As Integer
Dim total As Double
Dim r As Integer
For i = 1 To UBound(itemsToReference)
If StrComp(itemToFind, itemsToReference(i)) = 0 Then
total = total + CDbl(resultArr(i))
End If
Next i
TotalItems = total
End Function
It returns #VALUE! whenever I run it. I'm not sure what the problem is, and all help will be appreciated.
You are passing Ranges, not arrays, so:
Function TotalItems(itemToFind As String, itemsToReference As Range, resultArr As Range) As Long
Dim i As Long, rng As Range
Dim total As Long
For i = 1 To (itemsToReference.Rows.Count)
If StrComp(itemToFind, itemsToReference(i, 1)) = 0 Then
total = total + CLng(resultArr(i, 1))
End If
Next i
TotalItems = total
End Function
(based on your example, I DIMed Long rather than Double)(note I index the ranges just like 2-D arrays)
In a worksheet cell, you could use:
=SUMPRODUCT(--(A1:A4="A")*(B1:B4))

resorting table using array

am trying to resort the data using Code consider the data shape like this :
Empid| 1/01/2019|2/01/2019 | 3/01/2019
-------------------------------------------
1 | A | B | A
2 | B | A | B
3 | B | C | C
4 | A | A | A
and the goal shape like this :
Empid | Date | Shift
---------------------
1 |1/01/2019 | A
1 |2/01/2019 | B
1 |3/01/2019 | A
2 |1/01/2019 | B
2 |2/01/2019 | A
2 |3/01/2019 | B
3 |1/01/2019 | B
3 |2/01/2019 | C
3 |3/01/2019 | C
4 |1/01/2019 | A
4 |2/01/2019 | A
4 |3/01/2019 | A
i used this code and reached to this shape using the code :
Empid | Shift
---------------------
1 |A
1 |B
1 |A
2 |B
2 |A
2 |B
3 |B
3 |C
3 |C
4 |A
4 |A
4 |A
this is the vba code :
Sub TransposeData()
Const FirstDataRow As Long = 2 ' presuming row 1 has headers
Const YearColumn As String = "A" ' change as applicable
Dim Rng As Range
Dim Arr As Variant, Pos As Variant
Dim Rl As Long, Cl As Long
Dim R As Long, C As Long
Dim i As Long
With ActiveSheet
Cl = .UsedRange.Columns.Count - .UsedRange.Column + 1
Rl = .Cells(.Rows.Count, Columns(YearColumn).Column).End(xlUp).Row
Set Rng = Range(.Cells(FirstDataRow, YearColumn), .Cells(Rl, Cl))
End With
Arr = Rng.Value
ReDim Pos(1 To (UBound(Arr) * UBound(Arr, 2)), 1 To 2)
For R = 1 To UBound(Arr)
For C = 2 To UBound(Arr, 2)
i = i + 1
Pos(i, 1) = Arr(R, 1)
Pos(i, 2) = Arr(R, C)
Next C
Next R
R = Rl + 5 ' write 5 rows below existing data
Set Rng = ActiveSheet.Cells(R, YearColumn).Resize(i, 2)
Rng.Value = Pos
End Sub
Use Power Query (aka Get & Transform in Excel 2016+).
Select the first column and UNpivot the other columns.
Rename the resultant Date column (which will be named Attributes by the GUI), and the Shift column (which will be named Value by the GUI).
If you want to do this in VBA, record a macro while running PQ
With a single cell selected in your table, select Get & Transform from Table/Range
Power Query will open. Ensure you have selected the first column. Then, from Transform, select the dropdown next to the Unpivot button. From that dropdown, select unpivot other columns.
After selecting that, you will see that you need to rename columns 2 and 3
After that, select one of the Close options from the File menu, and load the results to either the same sheet or another sheet.
Now you can rerun the query if your data changes.
And, as I wrote above, if you need to do this using VBA, just record a macro while you go through the steps.
I also suggest you search SO for unpivot and you'll get a lot of information.
Array Approach
Option Explicit
Public Sub Rearrange()
Dim t#: t = timer ' stop watch
Dim ws As Worksheet ' worksheet object
Set ws = ThisWorkbook.Worksheets("Sheet3") ' << change to sheet name
Const STARTCOL = "A" ' << change to your needs
' [1] get last row in column A
Dim r&, c& ' used rows/cols (assuming no blanks)
r = ws.Range(STARTCOL & ws.Rows.count).End(xlUp).Row
c = ws.Columns(STARTCOL).End(xlToRight).Column - ws.Columns(STARTCOL).Column
' [2] get values to 1-based 2-dim variant arrays
Dim tmp, tgt
tmp = ws.Range(ws.Cells(1, STARTCOL), ws.Cells(r, c + 1)).Value2
ReDim tgt(1 To c * (UBound(tmp) - 1) + 1, 1 To c) ' resize target array
' [3] rearrange data in target array
Dim i&, ii&, j&
For i = 2 To UBound(tmp)
For j = 2 To UBound(tmp, 2) ' get row data
ii = (i - 1) * c + j - c ' calculate new row index
tgt(ii, 1) = tmp(i, 1) ' get ID
tgt(ii, 2) = tmp(1, j) ' get date
tgt(ii, 3) = tmp(i, j) ' get inditgtidual column data
Next j
Next i
tgt(1, 1) = "EmpId": tgt(1, 2) = "Date": tgt(1, 3) = "Shift" ' get captions
' [4] write target array back wherever you want it to ' << redefine OFFSET
ws.Range("A1").Offset(0, c + 2).Resize(UBound(tgt, 1), UBound(tgt, 2)) = tgt
MsgBox "Time needed: " & Format(timer - t, "0.00") & " seconds."
End Sub
Note
You should format the target range with your preferred date formatting, e.g. "dd/mm/yyyy;#" .

Excel VBA: Scripting.Dictionary Calculations

I have the following values in a spreadsheet:
Printer Name | Pages | Copies
HP2300 | 2 | 1
HP2300 | 5 | 1
Laser1 | 2 | 2
Laser1 | 3 | 4
HP2300 | 1 | 1
How can I get the total number of pages printed (pages * copies) on each printer like this:
Printer Name | TotalPages |
HP2300 | 8 |
Laser1 | 16 |
I managed to create a list counting the number of times a printer was used to print:
Sub UniquePrints()
Application.ScreenUpdating = False
Dim Dict As Object
Set Dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant
varray = Sheets("Prints").Range("E:E").Value
For Each element In varray
If Dict.exists(element) Then
Dict.Item(element) = Dict.Item(element) + 1
Else
Dict.Add element, 1
End If
Next
Sheets("Stats").Range("D6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.keys)
Sheets("Stats").Range("E6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.items)
Application.ScreenUpdating = True
End Sub
How can I calculate the total pages for each print (row) (pages*copies) and save that in the dictionary instead of just adding 1?
Thank you for your help
Read in the columns E:G rather than just E and use the second dimension of that array to add pages * copies, rather than adding 1.
Sub UniquePrints()
Dim Dict As Object
Dim vaPrinters As Variant
Dim i As Long
Set Dict = CreateObject("scripting.dictionary")
vaPrinters = Sheets("Prints").Range("E2:G6").Value
For i = LBound(vaPrinters, 1) To UBound(vaPrinters, 1)
If Dict.exists(vaPrinters(i, 1)) Then
Dict.Item(vaPrinters(i, 1)) = Dict.Item(vaPrinters(i, 1)) + (vaPrinters(i, 2) * vaPrinters(i, 3))
Else
Dict.Add vaPrinters(i, 1), vaPrinters(i, 2) * vaPrinters(i, 3)
End If
Next i
Sheets("Stats").Range("D6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.keys)
Sheets("Stats").Range("E6").Resize(Dict.Count, 1).Value = _
WorksheetFunction.Transpose(Dict.items)
End Sub
It's possible to use an array formula to get cells populated:
={SUMPRODUCT(IF($A$2:$A$6=$F2;1;0);$B$2:$B$6;$C$2:$C$6)}
The formula is inserted from formula window with Ctrl-Shift-Enter. Curled brackets are inserted by excel, not by a user. The formula can be copied elsewhere.

Excel: Concatenate last non empty cells in a column

Since my previous post was closed, but the problem remains, I'll rephrase it here. I've came up with the following:
Function JoinLastInColIfEmpty(range_ As Range, delim_ As String)
Dim cell As Range, result As String, current As String
For Each cell In range_
current = LastNonEmptyInCol(cell)
If current <> "" Then
result = result & current & delim_
End If
Next
If Not IsEmpty(result) Then
result = Left(result, Len(result) - Len(delim_))
End If
JoinLastInColIfEmpty = result
End Function
Function LastNonEmptyInCol(cell_ As Range)
Dim tmp As Range
tmp = cell_ '<< The problem occurs here
Do Until Not IsEmpty(tmp) Or tmp.Row = 1
tmp = tmp.Offset(-1, 0)
Loop
LastNonEmptyInCol = tmp.Value
End Function
The problem is that the function never ends, so my questions are:
What is wrong with my script?
What should I do to solve my problem?
To answer your direct question, there are a couple of errors in LastNonEmptyInCol
Function LastNonEmptyInCol(cell_ As Range)
On Error Resume Next
Dim tmp As Range
Set tmp = cell_ '<< The problem occurs here ' <<<<< use Set
Do Until Not IsEmpty(tmp) Or tmp.Row = 1 ' <<<<< use tmp not cell_
Set tmp = tmp.Offset(-1, 0) ' <<<<< use Set
Loop
LastNonEmptyInCol = tmp.Value
End Function
That said, I think it is a very inefficient solution, and does not quite solve your stated problem
results will be
A | B | C | D | Concat
-----+-----+-----+-----+---------
1 | 2 | X | 5 | 12X5
| | f | 3 | 12f3
| 5 | R | 12 | 15R12
Z | 3 | T | | Z3T12
| G | | | ZGT12
Here's another version which might be better
Function MyJoinLastInColIfEmpty(range_ As Range, delim_ As String)
Dim vData As Variant
Dim cl As Range
Dim i As Long
Dim result As Variant
vData = range_
For i = 1 To UBound(vData, 2)
If vData(1, i) = "" Then
Set cl = range_.Cells(1, i).End(xlUp)
If cl <> "" Then
vData(1, i) = cl.Value
End If
Else
Exit For
End If
Next
For i = 1 To UBound(vData, 2)
result = result & vData(1, i) & delim_
Next
MyJoinLastInColIfEmpty = Left(result, Len(result) - Len(delim_))
End Function
I did not really try to understand the whole thing, but since tmp is an (range) object, you must use
Set tmp = ....
With help rows/columns this can be achieved with formulas:
-Placed in cell F1 array entered (Ctrl+Shift+Enter) then scrolled to however many cells you have:
{=INDEX(A$1:A1,MAX(IF(ISBLANK(A$1:A1),0,ROW(A$1:A1))))}
-Placed in cell K1, refers to first cell in F1, no need for array here.
=IF(ISBLANK(A1),IF(SUM(NOT(ISBLANK(INDEX($A1:A1,0)))+0)>0,"",F1),F1)
-Placed wherever you want the results. MCONCAT is a UDF function found in a free Add-in written in C++, CONCATENATE is Excel's built in formula.
=MConCat(K1:N1) or =CONCATENATE(K1,L1,M1,N1)
My personal preference would be the VBA way though. I'm sure someone smarter than me could come up with some better formulas.

Resources