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

mersilen

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,101
Excel Vers. ve Dili
excel 2007 türkçe
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
 

Ekli dosyalar

Son düzenleme:

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
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

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,101
Excel Vers. ve Dili
excel 2007 türkçe
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ş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
Else satırından sonra
a=WorksheetFunction.Match (Cells (i,1),s.Range (A:A),0)
kodunu ekleyiniz.
 

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,104
Excel Vers. ve Dili
office2010
Alternatif,

Kod:
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

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,101
Excel Vers. ve Dili
excel 2007 türkçe
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.

Kod:
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ş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
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
 

Ekli dosyalar

Muhammet Okumuş

Destek Ekibi
Destek Ekibi
Katılım
28 Eylül 2007
Mesajlar
3,967
Excel Vers. ve Dili
2013 Türkçe
Ziynettin Bey'in cevabı da çözüme ulaşıyor. Hem de daha hızlı.
 

mersilen

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,101
Excel Vers. ve Dili
excel 2007 türkçe
Ö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

Kod:
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
 

Ekli dosyalar

Son düzenleme:

Ziynettin

Destek Ekibi
Destek Ekibi
Katılım
18 Nisan 2008
Mesajlar
1,104
Excel Vers. ve Dili
office2010
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

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,101
Excel Vers. ve Dili
excel 2007 türkçe
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.
 
Üst