Combining matching values.

[Robert87]

Hello.

Could anyone help me figure this out. I don´t even know if it´s possible, but it´s worth a shot.

I want to make a macro that combines a certain column´s values of other column´s values match. Column B should always be the column that has it values added, as long as Colum A, C and D all match with each other.

And I need to be able to change data in thoose columns as I please.




15138

I´ve attached a big example post, and I´ll write a smaller example down below.




58 650
2
1 485
B310-1016


58 650
2
1 485
B310-1016


58 650
4
1 380
B310-1011


58 650
4
1 380
B310-1011







I wan´t thoose lines to read:


58 650
4
1 485
B310-1016


58 650
8
1 380
B310-1011










Help with this issue would be much appreciated.

[Paul_Hossler]

Here's a simple way. Sorts the data first, and then adds col 2 and deletes from the bottom up

A pivot table would probably also work without a macro




Option Explicit
Sub PHH()
Dim rData As Range
Dim iRow As Long

Set rData = ActiveSheet.Cells(1, 1).CurrentRegion

Application.ScreenUpdating = False

With ActiveSheet
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=rData.Columns(1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=rData.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=rData.Columns(4), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SetRange rData
.Sort.Header = xlGuess
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply

For iRow = rData.Rows.Count - 1 To 1 Step -1
If .Cells(iRow + 1, 1).Value = .Cells(iRow, 1).Value And _
.Cells(iRow + 1, 3).Value = .Cells(iRow, 3).Value And _
.Cells(iRow + 1, 4).Value = .Cells(iRow, 4).Value Then _

.Cells(iRow, 2).Value = .Cells(iRow, 2).Value + .Cells(iRow + 1, 2).Value
.Rows(iRow + 1).EntireRow.Delete
End If
Next iRow
End With

Application.ScreenUpdating = True
End Sub

[Robert87]

Thanks alot! Works perfectly!

[Robert87]

I´ve been using this script for a while now and it works like a charm.


Could I make this script only run in a defined area? Let´s say I wan´t it only to use the cells in C5:H20. Is that possible?

[Paul_Hossler]

Without seeing the data layout, a GUESS would be ...



Set rData = ActiveSheet.Range("C5").CurrentRegion

[Robert87]

With that I can´t get it to skip the first few rows.

[Natasha]

Thank you Paul its a great help

[Paul_Hossler]

As I said "Without seeing the data layout, ... "

How about posting a WB or at least a screen shot?

[Robert87]

Ohh right, ofcourse. Sorry.

Here is my workbook.
16106




What I need is:

Under each profile I want the amount to be combined if both the Lenght and Type match.

[Paul_Hossler]

Sorry, but the data in that WB doesn't look anything like the data in your #1 post, the layout is different, the data format is different, plus there is data in hidden columns that you might want to keep

Can you repeat in words using cell references what you're looking to do?

16107

[Robert87]

Ohh. Sorry. I forgot to hide that sheet.

It´s the sheet "Bearbetning" I want help with.
16112

Under "Profile 1" I want the values in column B to be combined if both C and D values match.
Under "Profile 2" I want the values in column F to be combined if both G and H values match.
Under "Profile 3" I want the values in column J to be combined if both K and L values match.
Under "Profile 4" I want the values in column N to be combined if both O and P values match.
Under "Profile 5" I want the values in column Q to be combined if both R and S values match.

And in all cases it´s the rows 12 to 198 that are being used.
Don´t worry about hidden data, if you want you can just copy the cells and paste them as values.


That´s what I need my program to do, if it´s possible.

[Paul_Hossler]

Maybe something like this



Option Explicit

Dim wsOrders As Worksheet, wsSummary As Worksheet

Sub GenerateSummary()
'setup
Application.ScreenUpdating = False
Set wsOrders = Worksheets("Bearbetning")

'delete old
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Summary").Delete
Application.DisplayAlerts = True
On Error GoTo 0

'create summary for orders to get headers
wsOrders.Copy After:=wsOrders
Set wsSummary = ActiveSheet
wsSummary.Name = "Summary"

'do profiles
Call pvtProfiles(wsSummary.Range("B12"))
Call pvtProfiles(wsSummary.Range("F12"))
Call pvtProfiles(wsSummary.Range("J12"))
Call pvtProfiles(wsSummary.Range("N12"))
Call pvtProfiles(wsSummary.Range("Q12"))

'cleanup
Application.ScreenUpdating = True
End Sub

Private Sub pvtProfiles(R As Range)
Dim rLast As Range, rSort As Range
Dim iRow As Long
'find last cell of 3rd column
Set rLast = R.Offset(0, 2).End(xlDown)

Range(R, rLast).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Do While rLast.Value = 0
Set rLast = rLast.Offset(-1, 0)
Loop
Set rSort = Range(R, rLast)

'sort by 2nd and 3rd col
With wsSummary.Sort
.SortFields.Clear
.SortFields.Add Key:=rSort.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=rSort.Columns(3), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'summary from bottom up
With rSort
For iRow = .Rows.Count To 2 Step -1
If .Cells(iRow - 1, 2).Value = .Cells(iRow, 2).Value And .Cells(iRow - 1, 3).Value = .Cells(iRow, 3).Value Then
.Cells(iRow - 1, 1).Value = .Cells(iRow - 1, 1).Value + .Cells(iRow, 1).Value
.Rows(iRow).Delete
End If
Next iRow
End With

End Sub




PS - it is possilbe to just use the WS 'Bearbetning' to summerize, but I really don't like to destroy the input source like that

[Robert87]

That script did exactly what I needed.

Thank you very much Paul_Hossler!

Much appreciated!