PDA

View Full Version : [SOLVED] Adding the exact IDs



hakunamatata
11-05-2012, 11:49 AM
Hello Everybody,
I want to add the exact ids and rearrange them accordingly, for the sake of example workbook is attached with this thread.

Teeroy
11-05-2012, 08:25 PM
Hi hakunamatata, couldn't you do this by PivotTable?

hakunamatata
11-05-2012, 10:52 PM
Hi, thanks alot for your reply. Actually i need something like pivot table but not pivot table. Pivot table gives the sum but i need the ids first then sum of that ids.

hakunamatata
11-06-2012, 12:45 AM
Hello Teeroy,If some solution exists then please let me now, i need it badly.

Teeroy
11-06-2012, 03:36 AM
Hi hakunamatata, try the following. It's only designed for A-C TEA ID per your example but you could add more to aID in the code:


Sub SortandSum()
Dim LR1 As Integer, LR2 As Integer
Dim i As Integer, j As Integer, Count1 As Integer, Count2 As Integer
Dim aID
Dim rDest1 As Range, rDest2 As Range, rDestSub As Range
Dim colLengths() As Integer
aID = Array("A", "B", "C")
ReDim colLengths(UBound(aID))
With Sheets("Sheet1")
'define data ranges
LR1 = .Range("A" & .Rows.Count).End(xlUp).Row
LR2 = .Range("D" & .Rows.Count).End(xlUp).Row
'determine max no. of data values (ID1 or ID2)
For i = 0 To UBound(aID)
Count1 = Application.WorksheetFunction.CountIf(.Range("A9:A" & LR1), aID(i))
Count2 = Application.WorksheetFunction.CountIf(.Range("D9:D" & LR2), aID(i))
colLengths(i) = max(Count1, Count2)
Next i
'Set up receiving sheet
With Sheets("Sheet2")
.Range("B1").Resize(1, 6) = Array("TEA ID1", "Value1", , , "TEA ID2", "Value2")
Set rDestSub = .Range("A1")
Set rDest1 = .Range("B2")
Set rDest2 = .Range("F2")
End With
'Receive the data
For i = 0 To UBound(colLengths)
For j = 1 To max(LR1, LR2)
If .Cells(j, 1) = aID(i) Then
rDest1.Value = aID(i)
rDest1.Offset(0, 1).Value = .Cells(j, 2)
Set rDest1 = rDest1.Offset(1, 0)
End If
If .Cells(j, 4) = aID(i) Then
rDest2.Value = aID(i)
rDest2.Offset(0, 1).Value = .Cells(j, 5)
Set rDest2 = rDest2.Offset(1, 0)
End If
Next j
Set rDestSub = rDestSub.Offset(colLengths(i) + 1, 0)
rDestSub.Resize(1, 7) = Array("Sum", aID(i), Application.WorksheetFunction.SumIf(.Range("A9:A" & LR1), aID(i), .Range("B9:B" & LR1)) _
, , "Sum", aID(i), Application.WorksheetFunction.SumIf(.Range("D9:D" & LR1), aID(i), .Range("E9:E" & LR1)))
Set rDest1 = rDestSub.Offset(1, 1)
Set rDest2 = rDestSub.Offset(1, 5)
Next i
End With
End Sub

Function max(i As Integer, j As Integer)
If i > j Then
max = i
Else
max = j
End If
End Function

hakunamatata
11-06-2012, 03:54 AM
Hello,Thanks for your code i am getting confuse because my worksheet was from A-E can you please attach the worksheet in which you attest the code.

Teeroy
11-06-2012, 04:32 AM
Hi hakunamatata, A-C = the values of the TEA ID (i.e. A, B or C) , not the columns. See the attached copy of your workbook where I tested the code.

hakunamatata
11-06-2012, 04:39 AM
thanks alot for your help. Works perfect.

hakunamatata
11-06-2012, 06:23 AM
Hello TeeroyThe code that you have written works fine, but the problem is that in array it stores only 3 values, but i have more than 1000 Ids which i cant save in array is it possible that it takes the full volumn instead of array.

Teeroy
11-06-2012, 01:43 PM
Hi hakunamatata, the code was written in a way that you only have to change the aID array to handle this. Now that you've said that there are 1000+ IDs I've incorporated a great Chip Pearson Function to get the distinct values and feed the array. See how this works for you.

hakunamatata
11-07-2012, 10:51 AM
Hello Teeroy,
Now your Macro works good in my project, Actually when i implement it in my project then i miss some thing, which i forget to mention you in my first Post. Please take a look at the attach workbook i have explain it there, just need a very little change in current code.
Thanks again for your help.

Teeroy
11-08-2012, 01:20 PM
Hi hakunamatata, try the attached.

For your information, if you reuse the DistinctValues Function and pass arrays you must set Option Base 1. I'd only used it with ranges before and found this hard way :banghead:.

hakunamatata
11-09-2012, 10:28 AM
Hello Teeroy,

The program that you have written works absolutely perfect. You are a genius,
Thanks alot for your help.