lütfen yardım!!aynı olanları tablo yap

[hazem_oz]

arkadaşlar ilgilenirseniz çok memnun olurum.size zahmet sayfa ekte.

 

[Necdet]

Merhaba,

Dosyanızda bir aşağı bir yukarı bir sağa bir sola gittim başım döndü.

Tam olarak ne yapılmasını istiyorsunuz anlamadım. Aynı olanlar diyorsunuz Aynı neye göre aynı?

Daha net açıklarsanız yardım alma şansınız artar.

 

[hazem_oz]

ilginize teşekkür ederim.şöyle söyliyim aynı renkte olanlar tek sırada ama adet olarak belirtilsin.Tekrar düzelterek ekledim üstadım.size zahmet tekrar bakarsanız

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub Icmal()
    Dim i       As Long
    Dim j       As Long
    Dim Sira    As Long
    Dim sa      As Worksheet
    Dim sc      As Worksheet
    Dim Adet    As Integer
    Dim Renk    As Long
    
    j = 5
    
    Set sa = Sheets("AÇIKLAMA")
    Set sc = Sheets("İCMAL")
    
    Application.ScreenUpdating = False
    sc.Range("A6:G65536").ClearContents
    
    sa.Range("B2:F2").Copy sc.Range("B6")
    Renk = sa.Range("A2").Interior.ColorIndex
    
    For i = 2 To sa.Cells(Rows.Count, "A").End(3).Row
    
        If Renk <> sa.Cells(i, "A").Interior.ColorIndex Then
            j = j + 1
            Sira = Sira + 1
            sc.Cells(j, "A") = Sira
            sc.Cells(j, "A").Interior.ColorIndex = Renk
            sc.Cells(j, "G") = Adet
            sc.Cells(j, "G").Interior.ColorIndex = Renk
            Renk = sa.Cells(i, "A").Interior.ColorIndex
            sa.Range("B" & i & ":F" & i).Copy sc.Cells(j + 1, "B")
            Adet = 1
        Else
            Adet = Adet + 1
        End If
        
    Next i
    j = j + 1
    Sira = Sira + 1
    sc.Cells(j, "A") = Sira
    sc.Cells(j, "A").Interior.ColorIndex = Renk
    sc.Cells(j, "G") = Adet
    sc.Cells(j, "G").Interior.ColorIndex = Renk
    
    Application.ScreenUpdating = False
    
    MsgBox "İcmal Hazırlanmıştır....."
    
End Sub

 

[Ergün Güler]

ilginize teşekkür ederim.şöyle söyliyim aynı renkte olanlar tek sırada ama adet olarak belirtilsin.Tekrar düzelterek ekledim üstadım.size zahmet tekrar bakarsanız

Selam,

Sub icmale_aktar()
Dim ac As Worksheet
Dim icm As Worksheet
Dim dizim(1 To 5, 1 To 65536)

Set ac = Sheets("AÇIKLAMA")
Set icm = Sheets("İCMAL")
son = ac.Range("A65536").End(3).Row

Application.ScreenUpdating = False
icm.Range("A6:G65536").ClearContents
n = 0
For i = 2 To son

For sut = 1 To 5

deg1 = ac.Cells(i, 2)
deg2 = ac.Cells(i, 3)
deg3 = ac.Cells(i, 4)
deg4 = ac.Cells(i, 5)
deg5 = ac.Cells(i, 6)

Next

For j = 1 To n
If dizim(1, j) = deg1 And dizim(2, j) = deg2 And dizim(3, j) = deg3 _
And dizim(4, j) = deg4 And dizim(5, j) = deg5 Then

GoTo dip:
End If

Next

n = n + 1

dizim(1, n) = deg1
dizim(2, n) = deg2
dizim(3, n) = deg3
dizim(4, n) = deg4
dizim(5, n) = deg5

icm.Cells(n + 5, "B") = dizim(1, n)
icm.Cells(n + 5, "C") = dizim(2, n)
icm.Cells(n + 5, "D") = dizim(3, n)
icm.Cells(n + 5, "E") = dizim(4, n)
icm.Cells(n + 5, "F") = dizim(5, n)
dip:
icm.Cells(j + 5, "G") = icm.Cells(j + 5, "G") + 1
icm.Cells(j + 5, "A") = n
Next

Application.ScreenUpdating = True

MsgBox "Tablo İCMAL Sayfasına Aktarıldı", vbInformation, "AKTARMA İŞLEMİ"

icm.Select
End Sub

İyi çalışmalar.

 

[hazem_oz]

necdet ve ergün kardeşim ikinizdende ALLAH RAZI OLSUN.tam istediğim şekil buydu.ergün arkadaşın yaptığı direk sayfaya attığından bu kodlarla sayfama eklicem.kolay gelsin.