[Help] To eliminate almost identical datas to be 1 & merge the differences among them

[Gravity101]

Hey guys, really need help from you with my excel work, and looks like i stuck in this point.

So i have a sheet, contains many datas.
The key of every row is No.PEB.
so the situation is like here :
i have a row the No.PEB is ex: 037175, this row has like more than 20 columns.

the problem is i have 3 rows of No.PEB with number 037175 the only difference is the last column of every row is different,

and i want to eliminate them, and merge the difference to be only one row.


Ugh, i don;t think i explain it well, so the exmple is here:


No.PEB------------Date-----------------Documents----------------CodeOfDocs

037175-------------7/7/11---------------AWB-------------------------12345

037175-------------7/7/11---------------BL-----------------------------85858

037175-------------7/7/11---------------Invoice-----------------------54765


nah, i want to make it to be


No.PEB------------Date-----------------AWB-----------------BL-------------------Invoice

037175-------------7/7/11---------------12345-------------85858------------------54765



thanks in advance guys.

 

[markmzz]

Gravity101,

Look at your PM.


Markmzz

 

[markmzz]

Gravity101,

Look at your Email.

Do some test and tell us if it work.

Markmzz

 

[hiker95]

Gravity101,


Thank you for the workbook.


Sample raw data in worksheet "Sheet 1" (not all columns are shown for brevity):

Excel Workbook
	A	B	X	Y
1	NO_PEB	TGL_PEB	Nama Dokumen	NO_DOK
2	037175	02/17/2010 00:00:00	AWB	SRG7ABZ277
3	037175	02/17/2010 00:00:00	INVOICE	PMS-042-2010
4	037175	02/17/2010 00:00:00	PACKING LIST	PMS-042-2010
5	037870	02/18/2010 00:00:00	AWB	SRG7ABZ304
6	037870	02/18/2010 00:00:00	INVOICE	PMS-044-2010
7	037870	02/18/2010 00:00:00	PACKING LIST	PMS-044-2010
8	039835	02/20/2010 00:00:00	AWB	SRG7ABZ355
9	039835	02/20/2010 00:00:00	INVOICE	PMS-048-2010
10	039835	02/20/2010 00:00:00	PACKING LIST	PMS-048-2010
11	042436	02/24/2010 00:00:00	AWB	SRG7ABZ417
12	042436	02/24/2010 00:00:00	INVOICE	PMS-053-2010
13	042436	02/24/2010 00:00:00	PACKING LIST	PMS-053-2010
14	042496	02/24/2010 00:00:00	AWB	SRG7ABZ446
15	042496	02/24/2010 00:00:00	INVOICE	PMS-054-2010
16	042496	02/24/2010 00:00:00	PACKING LIST	PMS-054-2010
17	043917	02/25/2010 00:00:00	AWB	SRG7ABZ529
18	043917	02/25/2010 00:00:00	INVOICE	PMS-058-2010
19	043917	02/25/2010 00:00:00	PACKING LIST	PMS-058-2010
20	043917	02/25/2010 00:00:00	AWB	SRG7ABZ529
21	043917	02/25/2010 00:00:00	INVOICE	PMS-058-2010
22	043917	02/25/2010 00:00:00	PACKING LIST	PMS-058-2010
23	043917	02/25/2010 00:00:00	AWB	SRG7ABZ529
24	043917	02/25/2010 00:00:00	INVOICE	PMS-058-2010
25	043917	02/25/2010 00:00:00	PACKING LIST	PMS-058-2010
26	043917	02/25/2010 00:00:00	AWB	SRG7ABZ529
27	043917	02/25/2010 00:00:00	INVOICE	PMS-058-2010
28	043917	02/25/2010 00:00:00	PACKING LIST	PMS-058-2010
29	044106	02/25/2010 00:00:00	AWB	SRG7ABZ527
30	044106	02/25/2010 00:00:00	INVOICE	PMS-057-2010
Sheet 1

After the macro in a new worksheet Results (not all rows shown for brevity):

Excel Workbook
	A	B	C	D	E	F	G	H
1	NO_PEB	TGL_PEB	NO Nama Dokumen	AWB	B/L	INVOICE	Letter Of Credit (L/C)	PACKING LIST
2	037175	02/17/2010 00:00:00		SRG7ABZ277		PMS-042-2010		PMS-042-2010
5	042436	02/24/2010 00:00:00		SRG7ABZ417		PMS-053-2010		PMS-053-2010
21	000057	01/02/2010 00:00:00			NYKS3140174560	PMS-207-2009		PMS-207-2009
60	005578	01/22/2010 00:00:00			MSCUJK395729	PMS-013-2010	CI0110.35553	PMS-013-2010
61	005641	01/22/2010 00:00:00			AHL/20/SMG/ZEE/10/0127	PMS-016-2010		PMS-016-2010
74	008191	01/30/2010 00:00:00			550390599	PMS-023-2010		PMS-023-2010
75	008273	01/30/2010 00:00:00			PTYSRG/SYD-016	PMS-022-2010		PMS-022-2010
76	008508	02/01/2010 00:00:00				PMS-025-2010		PMS-025-2010
77	008528	02/01/2010 00:00:00			NYKS3140044140	PMS-024-2010		PMS-024-2010
84	009848	02/05/2010 00:00:00			49030303002011A	PMS-031-2010		PMS-031-2010
85	009924	02/06/2010 00:00:00				PMS-042-2010		PMS-042-2010
86	010000	02/07/2011 00:00:00			NYKS3140068380	PMS-037-2011		PMS-037-2011
87	010019	02/07/2011 00:00:00			MOLU14600468521	PMS-036-2011		PMS-036-2011
88	010105	02/08/2010 00:00:00			550493757	PMS-034-2010		PMS-034-2010
89	010282	02/08/2010 00:00:00				PMS-035-2010		PMS-035-2010
90	010740	02/09/2010 00:00:00			PTYSRG/BNE-021	PMS-038-2010		PMS-038-2010
91	010743	02/09/2010 00:00:00			PTYSRG/SYD-019	PMS-037-2010		PMS-037-2010
92	092676	11/27/2010 00:00:00				PMS-289-2010	024CDI2717	PMS-289-2010
93	092986	11/29/2010 00:00:00				PMS-293-2010		PMS-293-2010
94	093036	11/29/2010 00:00:00				PMS-291-2010		PMS-291-2010
95	093037	11/29/2010 00:00:00				PMS-292-2010		PMS-292-2010
96	093772	12/24/2009 00:00:00			SRMFOSB00683	PMS-202-2009		PMS-202-2009
97	093827	12/24/2009 00:00:00			SRMSKGB00684	PMS-203-2009		PMS-203-2009
98	094140	12/02/2010 00:00:00				PMS-294-2010		PMS-294-2010
99	094165	12/28/2009 00:00:00			4903-0303-912.016.A	PMS-205-2009	L3017CI001623/09	PMS-205-2009
100	094181	12/28/2009 00:00:00			4903-0303-912.016.B	PMS-206-2009	00762ECD09001126	PMS-206-2009
101	094631	12/03/2010 00:00:00				PMS-295-2010		PMS-295-2010
102	094832	12/04/2010 00:00:00			ID1301680	PMS-296-2010		PMS-296-2010
122	102971	12/31/2010 00:00:00			AHL/20/SMG/ANR/11/0003	PMS-002-2011		PMS-002-2011
123	900277	06/21/2010 00:00:00	2922/DJ-DAGLU/ETPIK/			071/JGW/VIII/10		071/JGW/VIII/10
124
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code, by highlighting the code and pressing the keys CTRL + C
2. Open your workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code by pressing the keys CTRL + V
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel, open the workbook, and press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Option Explicit
Sub ReorgData()
' hiker95, 08/13/2011
' http://www.mrexcel.com/forum/showthread.php?t=571512
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, LR2 As Long, a As Long, aa As Long, SR As Long, ER As Long, FC As Long
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet 1")
w1.AutoFilterMode = False
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Columns("A:B").Copy wR.Columns("A:B")
w1.Columns("X:Y").Copy wR.Columns("C:D")
w1.UsedRange.AutoFilter
LR = wR.Cells(Rows.Count, "A").End(xlUp).Row
With wR.Range("E2:E" & LR)
  .FormulaR1C1 = "=RC[-4]&RC[-3]"
  .Value = .Value
End With
wR.Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns("G:H"), Unique:=True
wR.Columns("C:C").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns("L:L"), Unique:=True
LR = wR.Cells(Rows.Count, "G").End(xlUp).Row
With wR.Range("I2:I" & LR)
  .FormulaR1C1 = "=RC[-2]&RC[-1]"
  .Value = .Value
End With
LR = wR.Cells(Rows.Count, "L").End(xlUp).Row
wR.Range("L2:L" & LR).Sort Key1:=wR.Range("L2"), Order1:=1, Header:=xlNo
wR.Range("M1").Resize(, LR - 1).Value = Application.Transpose(Range("L2:L" & LR))
wR.Range("L1:L" & LR).Clear
LR2 = wR.Cells(Rows.Count, "I").End(xlUp).Row
With wR.Range("J2:J" & LR2)
  .FormulaR1C1 = "=MATCH(RC[-1],C[-5],0)"
  .Value = .Value
End With
LR = wR.Cells(Rows.Count, "A").End(xlUp).Row
With wR.Range("K2:K" & LR2 - 1)
  .FormulaR1C1 = "=R[1]C[-1]-1"
  .Value = .Value
End With
wR.Range("K" & LR2) = LR
LR = wR.Cells(Rows.Count, "G").End(xlUp).Row
For a = 2 To LR Step 1
  SR = wR.Range("J" & a)
  ER = wR.Range("K" & a)
  For aa = SR To ER Step 1
    If wR.Range("C" & aa) = "" Then
      wR.Range("L" & a) = wR.Range("D" & aa)
    Else
      FC = 0
      On Error Resume Next
      FC = Application.Match(wR.Range("C" & aa), wR.Rows(1), 0)
      On Error GoTo 0
      If FC > 0 Then wR.Cells(a, FC) = wR.Range("D" & aa)
    End If
  Next aa
Next a
wR.Columns("I:K").Delete
wR.Columns("A:F").Delete
If Application.CountA(wR.Range("C:C")) = 0 Then
  wR.Columns("C:C").Delete
Else
  wR.Range("C1") = "NO Nama Dokumen"
End If
wR.Range("A1:B1").Interior.ColorIndex = xlNone
wR.UsedRange.Columns.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm


Then run the ReorgData macro.

 

[Marcol]

Cross posted at Excel Forum
http://www.excelforum.com/excel-gen...e-1-and-merge-the-differences-among-them.html