Combine Rows & Sum Values in a Worksheet - excel

I have an excel sheet with the below (pipe "|" to delimit columns) data.
A|B|C|X|50|60
D|E|F|X|40|30
A|B|C|X|10|20
A|B|C|Y|20|20
A|B|C|X|20|70
D|E|F|X|10|50
A|B|C|Y|10|10
The result I am trying to get is:
A|B|C|X|80|150
A|B|C|Y|30|30
D|E|F|X|50|80
Values A, B, C and D, E, F are like unique identifiers. Actually only A or D can be considered. Values X and Y are like "types", and the integers are the values to sum. This sample was simplified, there are thousands of unique identifiers, dozen of types and dozens of values to sum. The rows are not sorted, the types can be located in higher or lower rows. I am trying to avoid the use of a pivot table.
Dim LastRow As Integer
Dim LastCol As Integer
Dim i As Integer
LastCol = Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column
LastRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LastRow
????
Next i
The code above gets to the point of looping through the rows but I am unclear on what to after that point.

Sort them on all alphabetic columns you deem important.
In an unused column to the right use a formula like the following in the second row,
=IF($A2&$B2&$C2&$D2=$A3&$B3&$C3&$D3, "", SUMIFS(E:E,$A:$A, $A2,$B:$B, $B2,$C:$C, $C2,$D:$D, $D2))
Copy that formula right one column then fill both columns down as far as your data goes
Filter on the two columns, removing blanks.
        
Optionally copy the data to a new report worksheet and remove columns E & F.
Addendum:
A more automated approach could be achieved with some form of array and some simple mathematical operations. I've chosen a dictionary object in order to take use of its indexed Key to recognize patterns in the first four alphabetic identifiers.
To use a scripting dictionary, you need to go into the VBE's Tools ► References and add Microsoft Scripting Runtime. The following code will not compile without it.
The following has been adjusted for dynamic columns of keys and integers.
Sub rad_collection()
Dim rw As Long, nc As Long, sTMP As String, v As Long, vTMP As Variant
Dim i As Long, iNumKeys As Long, iNumInts As Long
Dim dRADs As New Scripting.Dictionary
dRADs.CompareMode = vbTextCompare
iNumKeys = 5 'possibly calculated by num text (see below)
iNumInts = 2 'possibly calculated by num ints (see below)
With ThisWorkbook.Sheets("Sheet4").Cells(1, 1).CurrentRegion
'iNumKeys = Application.CountA(.Rows(2)) - Application.Count(.Rows(2)) 'alternate count of txts
'iNumInts = Application.Count(.Rows(2)) 'alternate count of ints
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).row
vTMP = .Cells(rw, 1).Resize(1, iNumKeys).Value2
sTMP = Join(Application.Index(vTMP, 1, 0), Chr(183))
If Not dRADs.Exists(sTMP) Then
dRADs.Add Key:=sTMP, Item:=Join(Application.Index(.Cells(rw, iNumKeys + 1).Resize(1, iNumInts).Value2, 1, 0), Chr(183))
Else
vTMP = Split(dRADs.Item(sTMP), Chr(183))
For v = LBound(vTMP) To UBound(vTMP)
vTMP(v) = vTMP(v) + .Cells(rw, iNumKeys + 1 + v).Value2
Next v
dRADs.Item(sTMP) = Join(vTMP, Chr(183))
End If
Next rw
rw = 1
nc = iNumKeys + iNumInts + 1
.Cells(rw, nc + 1).CurrentRegion.ClearContents 'clear previous
.Cells(rw, nc + 1).Resize(1, nc - 1) = .Cells(rw, 1).Resize(1, nc - 1).Value2
For Each vTMP In dRADs.Keys
'Debug.Print vTMP & "|" & dRADs.Item(vTMP)
rw = rw + 1
.Cells(rw, nc + 1).Resize(1, iNumKeys) = Split(vTMP, Chr(183))
.Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = Split(dRADs.Item(vTMP), Chr(183))
.Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts) = _
.Cells(rw, nc + iNumKeys + 1).Resize(1, iNumInts).Value2
Next vTMP
End With
dRADs.RemoveAll: Set dRADs = Nothing
End Sub
Just run the macro against the numbers you have provided as samples. I've assumed some form of column header labels in the first row. The dictionary object is populated and duplicates in the combined identifiers have their numbers summed. All that is left is to split them back up and return them to the worksheet in an unused area.
    
Location of Microsoft Scripting Runtime - In the Visual Basic Editor (aka VBE) choose Tools ► References (Alt+T,R) and scroll down a little more than halfway to find it.
        

Related

Counter is working, but how to make it list counted values?

I have a macro with counter for unique values that met specific conditions. As you can see on the image, I have list of unique values in column F. Macro checks, if value is listed in column AE (can contain duplicated lines) and checks if there is no "OB" in column AH. Then returns how many values it found in cell K2. But I need this counter to also list these values in column AD, but I am struggling to make it happen. I checked many forums and managed to crash Excel twice already. Any ideas how to achieve it?
Dim myTbl As range, mStr As String, Miss As Long, xCol As Variant
Set myTbl = Sheets("OB").range("AE2") '
xCol = "AH"
mStr = ""
Set myTbl = range(myTbl, myTbl.End(xlDown).Offset(0, 1))
xCol = Cells(1, xCol).Column - myTbl.Cells(1, 1).Column + 1
For i = 1 To myTbl.Rows.count
If myTbl.Cells(i, 1) <> "" Then
If myTbl.Cells(i, xCol) <> "OB" And InStr(1, mStr, "##" & myTbl.Cells(i, 1), vbTextCompare) = 0 Then
mStr = mStr & "##" & myTbl.Cells(i, 1)
Miss = Miss + 1
End If
End If
Next i
If Miss > 0 Then
range("K2") = Miss & " still active"
range("K2").Font.ColorIndex = 46
Else
range("K2") = "None"
range("K2").Font.ColorIndex = 10
End If
Please, test the next code. It, also, is able to return how many occurrences per each Value x have been found (if more than one per each exist):
Sub ExtractUniqueCondValues()
Dim sh As Worksheet, lastR As Long, arr, i As Long, dict As Object
Set sh = Sheets("OB")
lastR = sh.Range("AE" & sh.rows.count).End(xlUp).row
arr = sh.Range("AE2:AH" & lastR).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr)
If arr(i, 4) <> "OB" Then dict(arr(i, 1)) = dict(arr(i, 1)) + 1
Next i
sh.Range("K2").Value = dict.count
sh.Range("AD2").Resize(dict.count, 1).Value = Application.Transpose(dict.Keys)
End Sub
About occurrences per each 'Value x' element, it can return in an adiacent column 'Value 2| 1 andValue 4` | 2, for your picture case... Of course, if it may have relevance for your purpose. The dictionary already keeps this data.
Maybe using formulas is an option for you? See column G where the formula in G2 is the following and copied down.
=IF(COUNTIFS(AE:AE,F2,AH:AH,"<>OB")>0,F2,"")
Using Count or Countifs may be an option instead of VBA.

Cross reference 2 different columns, then put count of values in another table

I have a worksheet, and I want to be able to go through one column (O) to find the different values, then go to another column (U) and count whether the sting is paper or electronic. Then, I want to be able to take the total of paper/electronic stings from U with each instance in O (source) and put it into the following table on a different sheet with VBA.
Due to the sensitivity of the data, I quickly made a table with basically what I mean. Pretend A is O and B is U.
And I want the output in this table, or if there is a better way to present the data:
I've tried making a pivot table, but it simply counts each instance of the paper/electronic string in the sheet, and I need to cross reference the values in O with U.
Here is the formula what you desire. Remember that we need to change source value and Fillining medium value in each row. you can see from the image that in formula for Source A values are "A" and "Paper" for paper count and "A" and "Electronic" for electronic count. the formulas for Source A are written at the bottom of the table and formula for Source C you can See from formula Bar. This is to show you the change you need to make in formula for each source.
if you have excel 365 you can just use the unique/countifs function. For simplicity I assume your data is in col A & B
To get the unique values (source) col E:
=UNIQUE(A:A)
To count (manually add "paper" as header in col F:
=COUNTIFS(A:A;E2;B:B;$F$1)
Do the same for the other values.
EDIT:
Anything can be done in code:
Option Explicit
Sub DictUniqueFinal()
Dim arr, arr2, arrH, j As Long, dict As Object, id As String
'setup some arrays
arrH = Split("Source, Paper, Electronic", ",")
arr = Sheet1.Range("A1").CurrentRegion.Offset(1, 0).Value2 'load source without headers
ReDim arr2(1 To UBound(arr), 1 To 3)
'setup the dict
Set dict = CreateObject("Scripting.Dictionary") 'create dictionary lateB
For j = 1 To UBound(arr) - 1 'traverse source
id = arr(j, 1)
If Not dict.Exists(id) Then 'create key
If arr(j, 2) = "paper" Then
dict.Add id, 1 & "," & 0
Else
dict.Add id, 0 & "," & 1
End If
Else 'update key
If arr(j, 2) = "paper" Then
dict(id) = Split(dict(id), ",")(0) + 1 & "," & Split(dict(id), ",")(1)
Else
dict(id) = Split(dict(id), ",")(0) & "," & Split(dict(id), ",")(1) + 1
End If
End If
Next j
'build final array
ReDim arr2(0 To dict.Count - 1, 1 To 3)
For j = 0 To dict.Count - 1
arr2(j, 1) = dict.Keys()(j)
arr2(j, 2) = Split(dict.Items()(j), ",")(0)
arr2(j, 3) = Split(dict.Items()(j), ",")(1)
Next j
'dump to sheet
With Sheet2
.Range(.Cells(1, 1), .Cells(1, UBound(arrH) + 1)).Value2 = arrH
.Range(.Cells(2, 1), .Cells(UBound(arr2) + 2, UBound(arr2, 2))).Value2 = arr2
End With
End Sub
It's a bit long and I had to hard code, but I found a solution, thanks to #AnmolKumar I looked in to Countif and found this:
ws2.Range("F15").Value2 = Excel.WorksheetFunction.CountIfs, _
(ws3.Range("O1:O" & lstRow2), "A", ws3.Range("U1:U" & lstRow2), "Paper")
I'll just have to do it for each different section

Excel index match with a condition to choose a specific column in a 3d matrix (formula or VBA)

I have two tables in Excel, one with categories and listings, and another with points based on the category and listing threshold. It goes as follows:
Categories table:
ID
CATEGORY
LISTINGS
Points
001
A
56
002
C
120
003
A
4
004
B
98
Points table:
Category
tier1
tier2
tier3
A
Tier 1
Tier 2
Tier 3
Range
1-30
31-90
91-
Points
10
20
30
B
Tier 1
Tier 2
Tier 3
Range
1-25
26-100
101-
Points
10
20
30
C
Tier 1
Tier 2
Tier 3
Range
1-40
41-80
81-
Points
10
20
30
I started with an INDEX MATCH formula pointing at the points:
=INDEX(Points!A1:D11, MATCH(Categories!B2, Points!A1:A11, 0)+2)
--> the +2 is to get the points directly
I also though of evaluating the thresholds with this formula:
=IF(Categories!C2 >= NUMBERVALUE(LEFT(Points!D3, FIND("-",Points!D3)-1)),Points!D4, IF(Categories!C2 >=NUMBERVALUE(LEFT(Points!C3, FIND("-",Points!C3)-1)),Points!C4, Points!B4))
I thought that the else if the if would make it faster.
Could someone help me populate the Points column in the Categories table? VBA code is also acceptable. The tables are in different sheets.
José, your original Match formula is the right starting place. It locates the particular sub-table to do a further lookup on. But in order to make this formula a whole lot simpler, can we change the ranges (1-30, 31-90, 91-) to have just their starting points (1, 31, 91)? If we do that simple change then we can use the approximate lookup feature of HLookup to easily and compactly specify the Lookup:
=HLookup($C2,Offset(Points!$A$1,Match($B2,Points!$A:$A,0),1,2,3),2,True)
In the middle of this formula you can see your original Match function to locate the correct sub-table based on the category. We need to feed that start point to OFFSET() to create a table range useful to the HLookup. Offset takes an anchor cell reference (top left of the Points table), number of rows to count down from there (result of the Match), number of columns to the right (1), the number of rows in the range (2), and the number of columns in the range (3).
The Hlookup is just like a VLookup, but for tables arranged left-to-right not top-to-bottom. The True as the last parameter is very important as it tells HLookup to use the range lookup instead of an exact match.
A slightly verbose formula which takes the data as originally formatted (using Excel 365 Let):
=LET(ranges,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0),0),
leftRanges,VALUE(LEFT(ranges,FIND("-",ranges)-1)),
points,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0)+1,0),
INDEX(points,MATCH(C2,leftRanges)))
As it's urgent this is what I got but I cannot continue before tomorrow. Assuming you can at least put the tiers next to the category (A on same line as tiers) this will get you the first tier. You just need to copy the whole formula in the "nextCol", with minor modifications to get the next tiers.
if you really cannot change the source you need to add an additional offset in the first match.
=IF(AND(D1>NUMBERVALUE(LEFT(INDIRECT("B"&MATCH(E1,A:A,0)),FIND("-",INDIRECT("B"&MATCH(E1,A:A,0)))-1)),D1<NUMBERVALUE(RIGHT(INDIRECT("B"&MATCH(E1,A:A,0)),2))),INDEX(B:D,MATCH(E1,A:A,0)+1,1),"nextCol")
Option Explicit
Sub Score()
Dim wsP As Worksheet, wsC As Worksheet, dict
Dim iLastRow As Long, r As Long, i As Long, j As Integer
Dim sCat As String, iListing As Integer
Dim data, ar
Set wsP = Sheets("Points")
Set wsC = Sheets("Categories")
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row
data = wsC.Range("A1:D" & iLastRow).Value2
' category to row lookup
For i = 1 To UBound(data)
If data(i, 1) = "Range" Then
dict.Add Trim(data(i - 1, 1)), i ' range
End If
Next
' scan points
iLastRow = wsP.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To iLastRow
sCat = Trim(wsP.Cells(r, "B"))
iListing = wsP.Cells(r, "C")
If dict.exists(sCat) Then
i = dict(sCat)
For j = 4 To 2 Step -1
ar = Split(data(i, j), "-") ' lower-upper limit
If iListing >= ar(0) Then ' check lower limit
' update points
wsP.Cells(r, "D") = data(i + 1, j) ' points
Exit For
End If
Next
Else
MsgBox "No match '" & sCat & "'", vbCritical, "ERROR row " & r
End If
Next
MsgBox "done"
End Sub
Please, try the next code. It uses arrays and should be very fast, working only in memory. Please use your sheets when setting shC and shP as your real sheets. I only use the active sheet and the next one for testing reason:
Sub GetPoints()
Dim shC As Worksheet, shP As Worksheet, lastRC As Long, lastRP As Long, arrBC, arrP, arrPP, arrFin
Dim i As Long, j As Long, p As Long, k As Long
Set shC = ActiveSheet 'use here your Categories sheet
Set shP = shC.Next 'use here your Points sheet
lastRC = shC.Range("A" & shC.rows.count).End(xlUp).row
lastRP = shP.Range("A" & shP.rows.count).End(xlUp).row
arrBC = shC.Range("B2:C" & lastRC).Value 'put the range B:C in an array
arrP = shP.Range("A2:D" & lastRP).Value 'put all the range in an array
ReDim arrFin(1 To UBound(arrBC), 1 To 1) 'redim the array to keep processed values
For i = 1 To UBound(arrBC) 'iterate between Categ array elements:
For j = 1 To UBound(arrP) 'iterate between Points array elements:
If arrP(j, 1) = arrBC(i, 1) Then 'if Category is found:
For p = 2 To 4 'iterate between the next array row elements
arrPP = Split(arrP(j + 1, p), "-") 'split the element by "-" to determine the interval
If arrPP(1) <> "" Then 'for the tier3 case:
If arrBC(i, 2) >= CLng(arrPP(0)) And arrBC(i, 2) <= CLng(arrPP(1)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
Else 'for the tier1 and tier2 cases:
If arrBC(i, 2) >= CLng(arrPP(0)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
End If
Next p
End If
Next j
Next i
'drop the final array result at once:
shC.Range("D2").Resize(UBound(arrFin), 1).Value = arrFin
End Sub

Match function for date matchup

I create an array "Checkarray()" to collect the A column data in worksheet "Gun Log". After that I create a "For" loop function for the A column data in worksheet "Gun Inventory".
By comparing the data in two worksheets I am trying to use the Match function to locate where there is a data match, and transferring the corresponding date from one worksheet to the other.
No matter how I adjust conditions the date transfer is always "10/1/2018". I don't know where this is from.
If there are several different results matched in one worksheet, which result will the match function give at the end? In the "Gun Log" worksheet for each gun there are several matched results and I suspect that is the cause of the error.
Private Sub submitBt_Click()
Dim i As Integer
Dim c As Long
Dim g As Long
Dim CheckArray() As String
With ThisWorkbook.Sheets("Gun Log")
For c = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
ReDim Preserve CheckArray(c - 1)
CheckArray(c - 1) = .Cells(c, "A").Value
Next c
End With
For g = 1 To UBound(CheckArray) Step 1
If UCase(CheckArray(g)) = UCase(.Cells(i, "A")) Then
.Cells(i, "E") = Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1)) + 1, "B").Value
Debug.Print Application.Match(CheckArray(g), .Columns(1))
Debug.Print Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1)) + 1, "B").Value
End If
Next g
Next i
End With
End Sub
Try to use all the arguments of Match() so that you can ensure you have an exact match.
You might be matching partially, which is why you only have one output. You used:
Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1)) + 1, "B").Value
'AND
Application.Match(CheckArray(g), .Columns(1))
The third argument for match is if it should be an exact match, so try:
Worksheets("Gun Log").Cells(Application.Match(CheckArray(g), .Columns(1), 0) + 1, "B").Value
'AND
Application.Match(CheckArray(g), .Columns(1), 0)
That "0" I added (third argument) means you need an exact match.

Cutting letters from alphanumeric cell entry, pasting to another cell

How can I set up a macro that will strip the letters from #####XX in column I and put them in to column L same row? Thanks!
Assuming you're working with the first sheet and you're always stripping off the last two characters while leaving the first 5 characters, the following code will work:
Public Sub StripOff()
Dim iRow as Integer
iRow = 2 'Assuming row 1 is headers, else make this 1
While Sheets(1).Range("I" + Cstr(iRow)).Value <> ""
Sheets(1).Range("L" + CStr(iRow)).Value = Right(Sheets(1).Range("I" + Cstr(iRow)).Value, 2)
Sheets(1).Range("I" + Cstr(iRow)).Value = Left(Sheets(1).Range("I" + Cstr(iRow)).Value, 5)
iRow = iRow + 1
Wend
End Sub
The operative words I'm understanding from your question are Cutting and strip. To my mind, this means that the last two letters are permanently removed from column I and placed in column L.
Sub cut2right()
Dim v As Long, vPFXS As Variant, vSFXS As Variant
With Worksheets("Sheet6")
vPFXS = .Range(.Cells(2, "I"), .Cells(Rows.Count, "I").End(xlUp))
ReDim vSFXS(1 To UBound(vPFXS), 1 To 1)
For v = LBound(vPFXS, 1) To UBound(vPFXS, 1)
If Len(vPFXS(v, 1)) > 1 Then
vSFXS(v, 1) = Right(vPFXS(v, 1), 2)
vPFXS(v, 1) = Left(vPFXS(v, 1), Len(vPFXS(v, 1)) - 2)
End If
Next v
.Cells(2, "I").Resize(UBound(vPFXS, 1), 1) = vPFXS
.Cells(2, "L").Resize(UBound(vPFXS, 1), 1) = vSFXS
End With
End Sub
Working with variant arrays should speed up working with many cells with variable length string values. If they were all the same length then manually running a Text-to-Columns command with a fixed length to an unused column and then copying and pasting the results to the appropriate column would have done just fine.
You can get the leading numeric characters from a string using the VBA Val function. To use this function on a worksheet you will need to create a User Defined Function (UDF) in a standard VBA module.
Function LeadingNumbers(Str As String) As Double
LeadingNumbers = Val(Str)
End Function
Simply enter the function in a cell and reference the cell containing the string you want "cleaned".

Resources