Consolidate several rows into a single row vba - vba

I need to create a sub to consolidate some data. I have several rows (anywhere from 4k to 20k) that I need to consolidate and sum the values from each column (from C to N).
The input data looks like this:
input
For the output, it should sum the columns for each SKU (Column A) and delete the rest.
Like this:
output
It should be simple enough, but I can’t seem to come up with an appropriate solution. I tried using an array with a scripting dictionary but I can’t figure out how to store more than a single value for each key. Sample (unfinished) code:
Dim sArray As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
sArray = Range(currentRange).Value
For i = 1 To UBound(sArray, 1)
For j = 3 To UBound(sArray, 2)
If dict.exists(sArray(i, 1)) = False Then
dict.Add sArray(i, 1), sArray(i, j)
Else
'this part is very wrong:
dict(sArray(i, 1)) = dict(sArray(i, j)) + sArray(i, j)
End If
Next
Next
Thank you very much in advance!

Try this, It sums the values in Column Q:AB then paste them back and removes the duplicates.
Sub dupremove()
Dim ws As Worksheet
Dim lastrow As Long
Set ws = Sheets("Sheet12") ' Change to your sheet
With ws
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
With .Range("C2:N" & lastrow)
.Offset(, 14).FormulaR1C1 = "=SUMIF(C1,RC1,C[-14])"
.Value = .Offset(, 14).Value
.Offset(, 14).ClearContents
End With
With .Range("A1:N" & lastrow)
.Value = .Value
.RemoveDuplicates 1, xlYes
End With
End With
Before:
After:

I came up with the following solution instead and it took 30 seconds to run it (not entirely my own idea, borrowed some code from someplace else):
Sub dupes()
Dim MyRange As Range
Dim RowNum As Long
RowNum = 1
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set MyRange = Range("A2:N14200") 'for test only, on the real sub it's dynamic
MyRange.Sort key1:=Range("A2"), order1:=xlAscending
For Each Row In MyRange
With Cells
While Cells(RowNum, 1) = Cells(RowNum + 1, 1) And Cells(RowNum + 1, 1) <> "" 'very important the second condition or it will continue to loop forever
For i = 3 To 14
Cells(RowNum, i) = Cells(RowNum, i) + Cells(RowNum + 1, i)
Next
Rows(RowNum + 1).EntireRow.Delete
Wend
End With
RowNum = RowNum + 1
Next
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
It's kinda messy but it does the trick. Thanks to everyone!

Related

VBA How to find a Specific Number based on Variable then Priority

I am trying to build a excel vba code that looks at data from three columns, takes the lowest 6 values of each variable (which there are four of) and also takes the adjacent column and pastes it in another sheet.
This is the input:
This is what I would like the output to be:
!
This is what the output actually is:
Actual Output
I stole a lot of this code from another post I saw, but it seems to be acting very randomly. I'm still not quite sure what the code is even doing, which is what makes it hard for me.
Any advice will help tremendously.
UPDATE: Using Ibo's fix on my sample data, it worked perfectly, however on my actual data it errored out. The reason I am doing this through a macro instead of manually is because it is a part of a much larger macro that is getting pieced together to predict production consumption of various raw materials and what needs to get staged.
Here's what happened:
Actual Input Data
Error 1004 Message and highlighted code
Output after failure
It looks like it got close, but didn't finish with the actual sort.
Sub TopPriorityPerPod()
Dim wsData As Worksheet
Dim wsDest As Worksheet
Dim rngData As Range
Dim rngFound As Range
Dim rngUnqGroups As Range
Dim GroupCell As Range
Dim lCalc As XlCalculation
Dim aResults() As Variant
Dim aOriginal As Variant
Dim lNumTopEntries As Long
Dim i As Long, j As Long, k As Long
'Change to grab the top X number of entries per category'
lNumTopEntries = 6
Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output it'
Set rngData = wsData.Range("A2", wsData.Cells(Rows.Count, "C").End(xlUp))
aOriginal = rngData.Value 'Store original values so you can set them back later'
'Turn off calculation, events, and screenupdating'
'This allows code to run faster and prevents "screen flickering"'
With Application
lCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
'If there are any problems with the code, make sure the calculation, events, and screenupdating get turned back on'
'On Error GoTo CleanExit
With rngData
'.Sort .Resize(, 1).Offset(, 1), xlAscending, .Resize(, 1).Offset(, 2), , xlDescending, Header:=xlYes
.Sort .Resize(, 1).Offset(, 1), xlDescending, Header:=xlYes
End With
With rngData.Resize(, 1).Offset(, 1)
.AdvancedFilter xlFilterInPlace, , , True
Set rngUnqGroups = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
.Parent.ShowAllData 'Remove the filter
ReDim aResults(1 To rngUnqGroups.Cells.Count * lNumTopEntries, 1 To 4)
i = 0
For Each GroupCell In rngUnqGroups
Set rngFound = .Find(GroupCell.Value, .Cells(.Cells.Count))
k = 0
If Not rngFound Is Nothing Then
For j = i + 1 To i + lNumTopEntries
If rngFound.Offset(j - i - 1).Value = GroupCell.Value Then
k = k + 1
aResults(j, 1) = rngFound.Offset(j - i - 1, -1).Value
aResults(j, 2) = rngFound.Offset(j - i - 1).Value
aResults(j, 3) = rngFound.Offset(j - i - 1, 1).Value
aResults(j, 4) = rngFound.Offset(j - i - 1, 2).Value
End If
Next j
i = i + k
End If
Next GroupCell
End With
'Output results'
wsDest.Range("A2").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
CleanExit:
'Turn calculation, events, and screenupdating back on'
With Application
.Calculation = lCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number <> 0 Then
'There was an error, show the error'
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
'Put data back the way it was
rngData.Value = aOriginal
End Sub
You can have different approaches. In this method I copy the data to another sheet called Result, then insert a table, sort the columns and then collect the range where the rows are more than 6 and then delete the whole rows at once, it will be really fast:
Sub Main()
Dim i As Long
Dim rng As Range
Dim tbl As ListObject
Dim WS As Worksheet
Dim WS2 As Worksheet
Set WS = Worksheets("Sheet1") 'this is where you have the data
Set WS2 = Worksheets.Add
WS2.Name = "Result"
WS.Range("A1").CurrentRegion.Copy
WS2.Paste
'sort priority column first
WS2.ListObjects.Add(xlSrcRange, Range(WS2.UsedRange.Address), , xlYes).Name = "Table1"
Set tbl = WS2.ListObjects("Table1")
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Priority]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'sort station column
tbl.Sort.SortFields.Clear
tbl.Sort.SortFields.Add _
Key:=Range("Table1[[#All],[Station]]"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With tbl.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'remove any row exceeding 6th occurrence
Dim cnt As Integer
For i = 1 To tbl.ListRows.Count - 1
If tbl.ListColumns("Station").DataBodyRange(i, 1).Value = tbl.ListColumns("Station").DataBodyRange(i + 1, 1).Value Then
cnt = cnt + 1
If cnt >= 6 Then
If rng Is Nothing Then
Set rng = tbl.ListColumns("Station").DataBodyRange(i + 1, 1)
Else
Set rng = Application.Union(rng, tbl.ListColumns("Station").DataBodyRange(i + 1, 1))
End If
End If
Else
cnt = 0 'reset the counter
End If
Next i
'remove rows
If Not rng Is Nothing Then
tbl.Unlist
rng.EntireRow.Delete
End If
End Sub
So I've put something together for you that should get you most of the way there.
You'll need to do a few things to get this working for your file (learning opportunity!):
(1) Adjust the ranges as relevant to your file
(2) Print the output to the worksheet. As of right now the output is being printed to the immediate debug window.
What this code will do is sort out each letters values into a collection named after the letters.
From there we convert the collection to an array. We then utilize the "Small" worksheet function on the arrays, and loop through the 6 lowest values.
Happy to help with any further questions you may have!
Public Function CollectionToArray(myCol As Collection) As Variant
'Thanks to user Vityata for this converter function (https://stackoverflow.com/users/5448626/vityata).
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.Count - 1)
For cnt = 0 To myCol.Count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
Sub ArraySort()
Dim Cell As Range
Dim KeyMultiple As String
Dim collA As New Collection
Dim collB As New Collection
Dim collC As New Collection
Dim collD As New Collection
Dim Rng_Col As Range
Set Rng_Col = Sheets("Sheet1").Range("A2:A22")
Dim GroupByArr As Variant
GroupByArr = Array("A", "B", "C")
Counter = 0
For i = 1 To 22
If Cells(i, 1).Value = "A" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collA.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "B" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collB.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "C" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collC.Add Item:=Cells(i, 2), Key:=KeyMultiple
ElseIf Cells(i, 1).Value = "D" Then
Counter = Counter + 1
KeyMultiple = Letter & "-" & Counter
collD.Add Item:=Cells(i, 2), Key:=KeyMultiple
End If
Next i
For i = 1 To 6
Debug.Print WorksheetFunction.Small(CollectionToArray(collA), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collB), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collC), i)
Debug.Print WorksheetFunction.Small(CollectionToArray(collD), i)
Next i
Set collA = New Collection
Set collB = New Collection
Set collC = New Collection
Set collD = New Collection
End Sub
here's a solution exploiting Array, Dictionary and SortedList object, that shuold be quite fast:
Option Explicit
Sub main()
Dim wsData As Worksheet: Set wsData = ActiveWorkbook.Sheets("copy") 'This is where your data is'
Dim wsDest As Worksheet: Set wsDest = ActiveWorkbook.Sheets("Sheet6") 'This is where you want to output
Dim stations As Variant, station As Variant
Dim iStation As Long
Dim stationsList As Object: Set stationsList = CreateObject("Scripting.Dictionary") ' use dictionary to collect unique station values
With wsData
stations = .Range("B2", .Cells(.Rows.Count, 2).End(xlUp)).Resize(, 3).Value
For iStation = 1 To UBound(stations, 1)
stationsList(stations(iStation, 1)) = stationsList(stations(iStation, 1)) & stations(iStation, 2) & "|" & stations(iStation, 3) & " " ' update current station priorities list and orders
Next
End With
Dim prioritiesAndOrders As Variant, priorityAndOrder As Variant, priority As Variant, order As Variant
Dim iPriority As Long, nPriorities As Long
For Each station In stationsList.Keys ' loop through unique stations
prioritiesAndOrders = Split(Trim(stationsList(station)), " ") ' get current station priorities and corresponding orders list
With CreateObject("System.Collections.SortedList") ' cerate and reference a sortedList object (it stores keys in ascending order)
For Each priorityAndOrder In prioritiesAndOrders ' loop through current station priorities and corresponding orders list
priority = Split(priorityAndOrder, "|")(0) ' get current priority
order = Split(priorityAndOrder, "|")(1) 'get current priority corresponding order
.Add priority, order ' store current priority as "key" of SortedList object and its corresponding order as its value
Next
nPriorities = WorksheetFunction.Min(.Count - 1, 5) ' define the current station number of priorities to manage
ReDim results(1 To nPriorities + 1, 1 To 3) As Variant ' size results array accordingly
For iPriority = 0 To nPriorities ' loop through current station sorted priorities (and corresponding orders) and fill results array with current station in column 1, its priorities in column 2 and priority corresponding order in column 3
results(iPriority + 1, 1) = station
results(iPriority + 1, 2) = .GetKey(iPriority)
results(iPriority + 1, 3) = .GetValueList()(iPriority)
Next
End With
wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1).Resize(nPriorities + 1, 3).Value = results ' write current station sorted priorities
Next
End Sub

Excel VBA cell upper/lower case depending other cell

I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
End Sub

Merge+unmerge cells to normalize table based on first column; insert newlines between merged content

I have an Excel sheet with cells in some columns merged:
I need to normalize it, such that the cells in the first column are unmerged (those should be considered the true "rows"), but such that unmerged groups of cells (in these "rows") are put into a single cell with newlines to retain the list-like content:
Note that in some columns besides the first, there may also be some merged cells, but in any case the first column should determine what a "row" in the output sheet should look like.
Does such a VBA script exist to do this?
UPDATE: Here's a little pseudo-code for what I was thinking:
foreach row:
determine height of merged cell in column A
unmerge cell in column A (content is in top cell of range?)
for each column after A:
if cell is merged, unmerge (content is in top cell of range?)
else concatenate cell contents with newline separator in top cell of row range
cleanup excess rows from the unmerging
Unfortunately I think there's a bit of complexity in some of these steps.
UPDATE#2: Based on the accepted answer, I created some new code to accomplish my goals:
Sub dlo()
Dim LastRow&, r&, c&, rowheight&, n&, Content$, NewText$
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
For r = 1 To LastRow
If Cells(r, 1).MergeCells Then
rowheight = Cells(r, 1).MergeArea.Cells.Count
For c = 1 To LastCol
NewText = vbNullString
For rr = r To (r + rowheight - 1)
Content = Cells(rr, c)
Cells(rr, c) = vbNullString
NewText = NewText & vbCrLf & Content
Next
Cells(r, c).UnMerge
Cells(r, c) = NewText
Next
'Cells(i + 1, 1).Resize(k - 1, 2).Delete Shift:=xlUp
'LastRow = LastRow - rowheight + 1
End If
DoEvents
Next
Application.DisplayAlerts = True
End Sub
The only thing I didn't finish was the deletion of resulting blank rows (I ended up just commenting those out since I knew a could just sort the table to eliminate the blanks).
If anyone has better ideas for how to describe this, please let me know so I can edit the title... I have a feeling this is not a rare need, so I'd like to help other find this.
Is this what you asking for?
Sub dlo()
Dim LastRow&, i&, j&, k&, n&, Content$, Text$
Application.DisplayAlerts = False
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
Do
i = i + 1
Text = vbNullString
If Cells(i, 1).MergeCells Then
k = Cells(i, 1).MergeArea.Cells.Count
n = Cells(i, 1).RowHeight
For j = 1 To k
Content = Cells(j + i - 1, 2)
Cells(j + i - 1, 2) = vbNullString
Text = Text & vbCrLf & Content
Next
Cells(i, 1).UnMerge
Cells(i, 2) = Mid(Text, 3)
Cells(i + 1, 1).Resize(k - 1, 2).Delete Shift:=xlUp
Rows(i).RowHeight = n * k
NewLastRow = LastRow - k + 1
End If
DoEvents
Loop Until i = NewLastRow
Application.DisplayAlerts = True
End Sub
The above code works fine to my dummy data.

Optimise excel VBA code - combine resident address

I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub

VBA Count of unique values with a second criteria

I have hit a roadblock trying to think through how I might write the VBA code that counts the number of unique order numbers and and whether the order status is open or closed for each salesperson.
I am working on writing the VBA that would affect Sheet2. I need the VBA to loop through Sheets("Sheet2").Range("A:A") and (1) lookup the name in Sheet1; (2a) count the unique order numbers that correspond with the salesperson's name and are "Open" and (2b) count the unique order numbers that correspond with the salesperson's name and are "Closed". I have designed "?"s for the values I am looking to calculate with the macro and included the answer numbers.
Any help is greatly appreciated. Please let me know if I can clarify anything.
Sheet1 - Orders
Sheet2 - Orders Summary
A B C
1 **Name** **Count-Uniq Open Orders** **Count-Uniq Closed Orders**
2 John ? (answer: 2) ? (answer: 0)
3 Ben ? (answer: 1) ? (answer: 1)
4 Fred ? (answer: 1) ? (answer: 0)
Tested:
Sub Tester()
Dim d1, d2, arrIn, r, tmp, nm, id, i
Dim c, k
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheets("orders")
arrIn = .Range(.Range("A2"), _
Cells(Rows.Count, 3).End(xlUp)).Value
End With
For r = 1 To UBound(arrIn, 1)
nm = arrIn(r, 1) 'name
id = arrIn(r, 2) 'order #
If Not d1.exists(nm) Then
d1.Add nm, Array(0, 0)
End If
If Not d2.exists(id) Then
tmp = d1(nm)
i = IIf(UCase(arrIn(r, 3)) = "OPEN", 0, 1)
tmp(i) = tmp(i) + 1
d1(nm) = tmp
d2.Add id, 0
End If
Next r
Set c = Sheets("summary").Range("a2")
For Each k In d1.keys
c.Resize(1, 3).Value = Array(k, d1(k)(0), d1(k)(1))
Set c = c.Offset(1, 0)
Next k
End Sub
Try this one :)
Sub Macro1()
Dim ws1 As Worksheet, ws2 As Worksheet, wsTemp As Worksheet
Dim rng As Range
Dim myformula1 As String, myformula2 As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set ws1 = ThisWorkbook.Sheets("Sheet1") 'where you have your Orders
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'where you have your summary which should have names in it
ws1.Copy ThisWorkbook.Sheets(1)
Set wsTemp = ActiveSheet: wsTemp.Name = "Temp"
With wsTemp
Set rng = .UsedRange
rng.RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
End With
myformula1 = "=COUNTIFS(" & wsTemp.Name & "!A:A,A2," & wsTemp.Name & "!C:C,""Open"")"
myformula2 = "=COUNTIFS(" & wsTemp.Name & "!A:A,A2," & wsTemp.Name & "!C:C,""Closed"")"
With ws2.Range(ws2.Range("A2"), ws2.Range("A" & ws2.Rows.Count).End(xlUp))
.Offset(0, 1).Formula = myformula1
.Offset(0, 2).Formula = myformula2
.Offset(0, 1).Resize(, 2).Value = .Offset(0, 1).Resize(, 2).Value
End With
wsTemp.Delete
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
No loop. Just to give you an alternative :D
Hope this helps in any way.
In cell B2 of sheet 2:
=SUM(IF(FREQUENCY(IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=B$1,Sheet1!$B$2:$B$10)),IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=B$1,Sheet1!$B$2:$B$10)))>0,1))
This is an array formula so to confirmit hold Ctrl + Shift and hit Enter, this will add a { and } at start and end respectively.
In cell C3:
=SUM(IF(FREQUENCY(IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=C$1,Sheet1!$B$2:$B$10)),IF(Sheet1!$A$2:$A$10=$A2,IF(Sheet1!$C$2:$C$10=C$1,Sheet1!$B$2:$B$10)))>0,1))
Same again, it's an array so Ctrl+Shift and Enter
And then copy the formulae down.
Just as an alternative, in terms of a pivot table solution the following answer covers the techniques required:
Simple Pivot Table to Count Unique Values