How to insert one Row from duplicate row data and fill insert row with packing Number

[SunnyAlv]

Hi guys, im have Problem and i hope u can help me

i just want to insert one row for every duplicate row data/ Table and fill that with something from each duplicate data, u can see image below


Table A --> Table B --> Table C

I Hope u help me With VBA

Thankss

 

[kevin9999]

I'm assuming you want the changes to take place where table A currently sits? If so, try the following code on a copy of your worksheet. It assumes the layout of your data is as per your image: starts in B2.

Option Explicit
Sub Fix_Format()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, r As Range
    Set ws = Worksheets("Sheet1")   '<-- *** Change to actual sheet name ***
    Set r = ws.Range("B2", ws.Cells(Rows.Count, "D").End(xlUp))
    Dim a, i As Long, c As Range
    a = r
    With ws
        For i = r.Rows.Count + 1 To 3 Step -1
            If a(i - 1, 2) <> a(i - 2, 2) Then
                .Rows(i).Insert
            End If
        Next i
        For i = 3 To .Cells(Rows.Count, "D").End(xlUp).Row + 1
            If .Cells(i, 2) = "" Then
                .Cells(i, 2) = "JOB " & .Cells(i - 1, 4)
                .Cells(i, 2).Resize(, 3).Interior.Color = vbYellow
            End If
        Next i
        Set c = .Range("B2:D" & ws.Cells(Rows.Count, "B").End(xlUp).Row)
        With c.Borders
            .LineStyle = xlContinuous
            .Color = vbBlack
            .Weight = xlThin
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Before:

Book1
	A	B	C	D	E
1
2		1	ABC	123
3		2	ABC	123
4		3	ACB	121
5		4	CBA	133
6		5	AAA	111
7		6	AAA	111
8		7	AAA	111
9		8	BBB	222
10
Sheet1

After:

Book1
	A	B	C	D	E
1
2		1	ABC	123
3		2	ABC	123
4		JOB 123
5		3	ACB	121
6		JOB 121
7		4	CBA	133
8		JOB 133
9		5	AAA	111
10		6	AAA	111
11		7	AAA	111
12		JOB 111
13		8	BBB	222
14		JOB 222
15
Sheet1

 

[SunnyAlv]

Saya berasumsi Anda ingin perubahan terjadi di tempat tabel A saat ini berada? Jika ya, coba kode berikut pada salinan lembar kerja Anda. Ini mengasumsikan tata letak data Anda sesuai gambar Anda: dimulai di B2.
[KODE=vba]
Opsi Eksplisit
Sub Fix_Format()
Aplikasi.Pembaruan Layar = Salah
Redupkan sebagai Lembar Kerja, r Sebagai Rentang
Set ws = Worksheets("Sheet1") '<-- *** Ubah ke nama sheet sebenarnya ***
Setel r = ws.Range("B2", ws.Cells(Rows.Count, "D").End(xlUp))
Redupkan a, i Selama, c Sebagai Rentang
sebuah = r
Dengan ws
Untuk i = r.Rows.Count + 1 Sampai 3 Langkah -1
Jika a(i - 1, 2) <> a(i - 2, 2) Maka
.Baris(i).Sisipkan
Berakhir jika
berikutnya saya
Untuk i = 3 Ke .Cells(Rows.Count, "D").End(xlUp).Row + 1
Jika .Cells(i, 2) = "" Lalu
.Cells(i, 2) = "PEKERJAAN" & .Cells(i - 1, 4)
.Cells(i, 2).Resize(, 3).Interior.Color = vbYellow
Berakhir jika
berikutnya saya
Setel c = .Range("B2:D" & ws.Cells(Rows.Count, "B").End(xlUp).Row)
Dengan c.Borders
.LineStyle = xlTerus menerus
.Warna = vbHitam
.Berat = xlTipis
Berakhir dengan
Berakhir dengan
Aplikasi.Pembaruan Layar = Benar
Akhiri Sub
[/KODE]

Sebelum:

Buku1
	A[/XH ][XH=w:48]B	C	D	E	1					[ /XD]
2		1	ABC[ /XD][XD=h:c]123
3		ABC	123
	3	ACB	121[ /XD][XD]
5		4	133
6		5	AAA	111		7		6	AAA
8		7	AAA	111
9[/XH ][XD=ch:14.4][/XD][XD=h:c]8[/XD][XD=h:c]BBB[/XD][XD=h:c]222[/XD][XD ][/XD]
Sheet1

[ /XR][XR] [XD] [XD =h:c]2[/XD] [XH ]4[/XH] [XD =h:c]CBA[/XD] [/ XR][XR] [XD =h:c]111[/XD] [XH] XD][XD][/XD][/XR]

Setelah:

Buku1
	A[/XH ][XH=w:48]B	C	D	E	1				1	ABC	123[/ XD][XD=cls:bl]
3		2	ABC	123
4		PEKERJAAN 123		[/XD ][XD=cls:bl]
5		3	ACB	121
6		PEKERJAAN 121
7		4	CBA	133
8		PEKERJAAN 133
9		5	AAA	111
10		6	AAA	111
11		7	AAA	111
12		PEKERJAAN 111
13		8	BBB	222	[ /XD]
14		PEKERJAAN 222
15			[/ XD][XD=cls:bt]
Sheet1

[ /XR][XR] [ XD=cls:bl][/XD] [XD =cls:bl][/XD] [ XD=cls:bl][/XD] [XD=cls:bl]

Dangg its work bro, thanks

 

[kevin9999]

Happy to help, and thanks for the feedback