• Merhaba Dostlar,
    yeni forum ile yola devam ediyoruz. Bu büyüklükte bir forum yeni bir sisteme taşımak epey bir yordu bizi. Üstelik bir de yeni XenForo Forum altyapısına geçtik.
    Eminim çok yerde hatalar ve eksikler vardır. Kısa sürede toparlayıp hızlı bir şekilde yolumuza devam edeceğiz.
    Lütfen gördüğünüz eksik ve hataları aşağıdaki bölüme dönderin. Sırasıyla inceleyip yapılabilirliği varsa üzerinde çalışacağım.
    HATA BİLDİRİM BAŞLIĞI
    Forumdaki kullanıcı adınızla ile giriş yapamıyorsanız kullanıcı adınızın sonuna 1 veya 2 gibi rakamlar ekleyerek deneyin.

    Hepimize Hayırlı Olsun!
    Hüseyin
ALTIN ÜYELİK Hakkında Bilgi
-----------------------

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

mersilen

Destek Ekibi
Destek Ekibi
Katılım
31 Aralık 2009
Mesajlar
1,073
Beğeniler
0
Excel Vers. ve Dili
excel 2007 türkçe
#1
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,491
Beğeniler
4
Excel Vers. ve Dili
2010 Türkçe
#2
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,073
Beğeniler
0
Excel Vers. ve Dili
excel 2007 türkçe
#3
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,491
Beğeniler
4
Excel Vers. ve Dili
2010 Türkçe
#4
Else satırından sonra
a=WorksheetFunction.Match (Cells (i,1),s.Range (A:A),0)
kodunu ekleyiniz.
 

Ziynettin

Altın Üye
Altın Üye
Katılım
17 Nisan 2008
Mesajlar
485
Beğeniler
7
Excel Vers. ve Dili
office2010
#5
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,073
Beğeniler
0
Excel Vers. ve Dili
excel 2007 türkçe
#6
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,491
Beğeniler
4
Excel Vers. ve Dili
2010 Türkçe
#7
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

mersilen

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

Altın Üye
Altın Üye
Katılım
17 Nisan 2008
Mesajlar
485
Beğeniler
7
Excel Vers. ve Dili
office2010
#10
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,073
Beğeniler
0
Excel Vers. ve Dili
excel 2007 türkçe
#11
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