ID'ye göre yan yana yazdırma

[Lacrymae]

Selamlar,

Elimde aşağıdaki gibi bir data var. Yaklaşık 5000 satırlık ir data.

ID	Kolon1	Kolon2	Kolon3	Kolon4	Kolon5	Kolon6	Kolon7	Kolon8
1	A	B	C	D	E	F	G	H
1	A	B	C	D	E	F	G	H
2	A	B	C	D	E	F	G	H
2	A	B	C	D	E	F	G	H
3	A	B	C	D	E	F	G	H
3	A	B	C	D	E	F	G	H
3	A	B	C	D	E	F	G	H
4	A	B	C	D	E	F	G	H
5	A	B	C	D	E	F	G	H
5	A	B	C	D	E	F	G	H

Bu yukarıdaki datayı aşağıdaki hale getirmem gerekiyor.

ID

Kolon1

Kolon2

Kolon3

Kolon4

Kolon5

Kolon6

Kolon7

Kolon8

Kolon1

Kolon2

Kolon3

Kolon4

Kolon5

Kolon6

Kolon7

Kolon8

Kolon1

Kolon2

Kolon3

Kolon4

Kolon5

Kolon6

Kolon7

Kolon8

1

A

B

C

D

E

F

G

H

A

B

C

D

E

F

G

H

2

A

B

C

D

E

F

G

H

A

B

C

D

E

F

G

H

3

A

B

C

D

E

F

G

H

A

B

C

D

E

F

G

H

A

B

C

D

E

F

G

H

4

A

B

C

D

E

F

G

H

5

A

B

C

D

E

F

G

H

A

B

C

D

E

F

G

H

Nereden başlamak lazım? Makro mu öğrenmek lazım yada script ile mi yapacağım işin içinden çıkamadım.

 

[Muzaffer Ali]

Merhaba.
Dosyanıza bir Module ekleyin.
Aşağıdaki kodu modüle kopyalayıp çalıştırın.

Sub Test()
    Dim Bak As Long
    Dim KolonSay1 As Integer, KolonSay2 As Integer
    Application.ScreenUpdating = False
    For Bak = Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
        If Cells(Bak, "A") = Cells(Bak - 1, "A") Then
            KolonSay1 = Cells(Bak, Columns.Count).End(xlToLeft).Column
            KolonSay2 = Cells(Bak - 1, Columns.Count).End(xlToLeft).Column + 1
            Range("B" & Bak & ":" & Cells(Bak, KolonSay1).Address).Copy Cells(Bak - 1, KolonSay2)
            Rows(Bak).Delete
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı.", vbInformation
End Sub

 

[Asri]

Alternatif;

birlestir.xlsm

1 file sent via WeTransfer, the simplest way to send your files around the world

we.tl

Sub birlestir()
    If WorksheetExists("LISTEXXX") Then
       Application.DisplayAlerts = False
       Sheets("LISTEXXX").Delete
       Application.DisplayAlerts = True
    End If
    
    ActiveSheet.Copy After:=ActiveSheet
    Set sh = ActiveSheet
    sh.Name = "LISTEXXX"
    
    sonsatir = sh.Cells(sh.Rows.Count, "A").End(3).Row
    
    sonsutunsay = 1
    For j = sonsatir To 2 Step -1
        sonsutun = sh.Cells(j, sh.Columns.Count).End(xlToLeft).Column
        ID = sh.Cells(j, "A").Value
        If ID = eskiid Then
          sonsutuneski = sh.Cells(j + 1, sh.Columns.Count).End(xlToLeft).Column
          sh.Range(Cells(j + 1, 2), Cells(j + 1, sonsutuneski)).Copy sh.Cells(j, sonsutun + 1)
          
          sonsutuneski = sh.Cells(j, sh.Columns.Count).End(xlToLeft).Column
          If sonsutuneski > sonsutunsay Then sonsutunsay = sonsutuneski
          
          sh.Rows(j + 1).Delete
        End If
        eskiid = ID
    Next j
    For j = 2 To sonsutunsay
        sh.Cells(1, j).Value = "KOLON " & j - 1
    Next j
End Sub

Public Function WorksheetExists(ByVal WorksheetName As String) As Boolean
   On Error Resume Next
   WorksheetExists = (Sheets(WorksheetName).Name <> "")
   On Error Resume Next
   On Error GoTo 0
End Function

 

[Lacrymae]

Cevaplar işin teşekkür ederim.
@Muzaffer Ali bey rüya gibi çalışıyor elinize sağlık.
@Asri bey birinci cevaptaki çalışınca bunu denemedim. Elinize sağlık yinede.