Mükerrer satırları yan yana yazdırma

[mersilen]

Merhabalar
Bir tablodaki mükerrer satırları yan yana yazdırabilir miyiz.?
Kaçıncı olduğunuda belirtmemiz lazım

Teşekkürler

Tabloyu yeniiden düzenledim
ID sütunu ekledim

 

[Muhammet Okumuş]

Merhaba, kodu deneyiniz.

Sub Aktar()
Application.ScreenUpdating = False
Set s = Sheets("Sayfa2")
s.Range("A2:BZ1000") = ""
son = Cells(Rows.Count, 1).End(3).Row
For i = 2 To son
If Cells(i, 6) = 1 Then
a = s.Cells(Rows.Count, 1).End(3).Row + 1
s.Range("A" & a & ":F" & a) = Range("A" & i & ":F" & i).Value
Else
c = Cells(i, 6) * 5 - 3
s.Range(s.Cells(a, c), s.Cells(a, c + 4)) = Range("B" & i & ":F" & i).Value
End If
Next
End Sub

 

[mersilen]

Muhammet bey
cevap için teşekkürler,
Tabloda bir ayrıntıyı atlamışım,
sorudaki tabloyu yeniden düzenledim.
Birinci sütundaki veriler sıralı değil.

 

[Muhammet Okumuş]

Else satırından sonra
a=WorksheetFunction.Match (Cells (i,1),s.Range (A:A),0)
kodunu ekleyiniz.

 

[Ziynettin]

Alternatif,

Sub ozet()
Dim a(), d As Object, krt As Variant
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, j As Integer
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A2:F" & s1.Cells(Rows.Count, 1).End(3).Row)
    For i = 1 To UBound(a)
        krt = ""
        For j = 2 To 6
            krt = krt & a(i, j) & "|"
        Next j
        d(a(i, 1)) = d(a(i, 1)) & krt
    Next i
    s2.[A2].Resize(d.Count) = Application.Transpose(d.keys)
    s2.[B2].Resize(d.Count) = Application.Transpose(d.items)
    Application.DisplayAlerts = False
    s2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
    s2.Cells.EntireRow.AutoFit
    s2.Select
MsgBox "İşlem bitti.", vbInformation
End Sub

 

[mersilen]

Sayın Muhammet Okumuş, mükerrerleri yan yana getiremiyor
Sayın Ziynettin, sizin kodlar hiç yan yana getiremiyor.

Tablodaki verileri yeniden düzenlemiştim
Ben bir vba kodu yazdım ama örnek dosyada çalışıyor
Asıl dosyaya uyarladığımda (18 sütun, 28000 satır) bilgisayar 1 saati aşkın çalışıyor.Sonuç müphem.
Satır ve sütun sayısı daha fazlada olabilir.
Sorunu nasıl aşabilirim.

Sub sırala()
Range("g1:bb20").Clear
sonsatır = Cells(Rows.Count, 1).End(xlUp).Row
For i = 5 To Cells(Rows.Count, 1).End(xlUp).Row  ' //tam sayı
 
If WorksheetFunction.CountIf(Range("A2:A" & i), Cells(i, 1)) > 1 Then
Set c = Range("A2:A" & i).Find(Cells(i, 1), LookIn:=xlValues)
s = c.Address
k = Cells(c.Row, 256).End(xlToLeft).Column + 1
Range("A" & i & ":F" & i).Copy
Cells(c.Row, k).PasteSpecial Paste:=xlValues
Range("A" & i & ":F" & i).Clear
Cells(1, 1).Select
Application.CutCopyMode = False

End If
Next i

For X = sonsatır To 2 Step -1
If Cells(X, "A") = "" Then Rows(X).Delete
Next X

End Sub

 

[Muhammet Okumuş]

Sub Aktar()
Application.ScreenUpdating = False
Set s = Sheets("Sayfa2")
s.Range("A2:BZ1000") = ""
son = Cells(Rows.Count, 1).End(3).Row
For i = 2 To son
If Cells(i, 6) = 1 Then
a = s.Cells(Rows.Count, 1).End(3).Row + 1
s.Range("A" & a & ":F" & a) = Range("A" & i & ":F" & i).Value

Else
a = WorksheetFunction.Match(Cells(i, 1), s.Range("A:A"), 0)
c = Cells(i, 6) * 5 - 3
s.Range(s.Cells(a, c), s.Cells(a, c + 4)) = Range("B" & i & ":F" & i).Value
End If
Next
End Sub

Cevabı telefondan yazdığım için
a = WorksheetFunction.Match(Cells(i, 1), s.Range("A:A"), 0) tırnak işaretlerini unutmuşum.

Bendeki sonuç görseldeki gibi

 

[Muhammet Okumuş]

Ziynettin Bey'in cevabı da çözüme ulaşıyor. Hem de daha hızlı.

 

[mersilen]

Öncelikle ilginize teşekkür ederim
Örnek tabloda kodlarınızı sorunsuz çalıştırdım
Muhammet bey sizin kodlar halen kasıyor

Ziynettin beyin kodunu 18 sütun 28000 satıra uyarlarken over flow hatası alıyorum
nereleri düzeltmem gerekir

Sub ozet()
Dim a(), d As Object, krt As Variant
Dim s1 As Worksheet, s2 As Worksheet
Dim i As Long, j As Integer
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
Set d = CreateObject("scripting.dictionary")
a = s1.Range("A2:R" & s1.Cells(Rows.Count, 1).End(3).Row)
    For i = 1 To UBound(a)
        krt = ""
        For j = 2 To 18
            krt = krt & a(i, j) & "|"
        Next j
        d(a(i, 1)) = d(a(i, 1)) & krt
    Next i
    s2.[A2].Resize(d.Count) = Application.Transpose(d.keys)
    s2.[B2].Resize(d.Count) = Application.Transpose(d.items)
    Application.DisplayAlerts = False
    s2.[B2].Resize(d.Count).TextToColumns Other:=True, OtherChar:="|"
    s2.Cells.EntireRow.AutoFit
    s2.Select
MsgBox "İşlem bitti.", vbInformation

End Sub

 

[Ziynettin]

a = s1.Range("A2:R" & s1.Cells(Rows.Count, 1).End(3).Row)

Fazla veriden olabilir. Satır sayısını azaltarak deneyin.

a = s1.Range("A2:R" & 1000) gibi...

 

[mersilen]

Ziynettin hocam
sizin "for j=2 to 6 " döngüdeki sütun sayısını artırdığım zaman (sütun sayım 18)
"sucscript out of range 9" hatası alıyorum.
Bunu nasıl düzeltebiliriz.