• FORUMU MOBİL UYGULAMADAN TAKİP EDİN

    Forumu isteyen üyelerimiz Tapatalk (Harici bir hizmet) üzerinden mobil uygulamadan takip edebilirler.
    iOS için : https://itunes.apple.com/app/id307880732?mt=8
    Android için : https://play.google.com/store/apps/details?id=com.quoord.tapatalkpro.activity
    adreslerinden indirebilirsiniz.

    Bir iki haftaya da foruma özel kendi uygulamamız yayında olacak.
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,530
Beğeniler
10
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,530
Beğeniler
10
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
529
Beğeniler
19
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,530
Beğeniler
10
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
529
Beğeniler
19
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