Sort Etmeden Aynı Kod Numaralarını Seçme!!

[mavisachal]

Arkadaşlar A kolonunda görülen Kodlar kısmında herbiri 8 hanedir ve ben burada tekrar yazmak yerine örnek oluşturdum.
Benim Burada yapmak istediğim A kolonundaki ilk koddan başlamak üzere oncelikle 100den A kolonunda kaç tane olduğunu bulmak ( bu örnekte 6 tane) bu kadar satır çalışma sayfasında satır eklemek( Cunku sıralı olmayabilr calışma sayfasının altında eklemem gerekenin altında veri olabilir bundan yeni satır eklemem lazım) Ve sonrasında bu 100 ile başlayanların A,B,C,D kolonlarını Çalışma sayfasına eklemek.

Bundan sonraki olay ise bir diğerine geçmek örnekte:200
yine aynılarını buna uygulamak yani A kolonumuzdaki tüm Farklı Kodlar icin bunu yapaması gerekiyor. Ben Çalışma sayfasında A ve B icin son halinin nasıl gorunmesi gerektiğini gorterdim. Acaba bunu makro ile yapabilir miyiz?

Örnekte Anlatmak istediğimi gorebilirsiniz.

Bunun icin ister Userform Kullanabilir isterseniz Başka bir sayfada sort ettirip yapabilirsiniz ancak istediğim şeyin hızlı olması gerekiyor arkadaşlar bir kısıtım yok yardımcı olursanız sevinirim.

Teşekkürler.

 

[Orion1]

Merhaba.
Dosyanız hazır.
Ekli dosyayı inceleyiniz.

Sub aktar()
Dim sonsat As Long
Sheets("Veri").Select
Range("F2:J65536").ClearContents
Sheets("Çalışma Sayfası").Range("A1:D65536").ClearContents
Application.ScreenUpdating = False
For i = 2 To Cells(65536, "A").End(xlUp).Row
    If WorksheetFunction.CountIf(Range("A2:A" & i), Cells(i, "A").Value) = 1 Then
        Range("J2").Value = Cells(i, "A").Value
        Range("A1:D" & Cells(65536, "A").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "J1:J2"), CopyToRange:=Range("F1:I1"), Unique:=False
        Range("A1").Select
        sonsat = Sheets("Çalışma Sayfası").Cells(65536, "A").End(xlUp).Row
        Range(Cells(1, "F"), Cells(Cells(65536, "F").End(xlUp).Row, "I")).Copy
        Sheets("Çalışma Sayfası").Range("A" & sonsat + 1).PasteSpecial
        Range("F2:J65536").ClearContents
    End If
Next
Application.ScreenUpdating = True
MsgBox "İŞLEM TMAMANDI"
End Sub

 

[veyselemre]

Sub aktar()
    Set sC = Sheets("Çalışma Sayfası")
    Set sV = Sheets("Veri")
    a = sV.[A1].Resize(, 4).Value
    sC.[a:d].Delete Shift:=xlUp
    son = sV.[a65536].End(3).Row
    sat = 1
    For x = 2 To son
        With sV.Cells(x, "A")
            say = WorksheetFunction.CountIf(sV.Range(sV.Cells(2, "A"), .Resize()), .Resize())
            If say = 1 Then
                say = WorksheetFunction.CountIf(sV.[a:a], .Resize())
                b = .Resize(, 4).Value
                With sC.Cells(sat, 1).Resize(, 4)
                    .Value = a
                    .Font.Bold = True
                    .HorizontalAlignment = xlCenter
                    .Offset(1).Resize(say, 4).Value = b
                    sat = sat + say + 1
                End With
            End If
        End With
    Next x
    Erase a, b
    Set sC = Nothing
    Set sV = Nothing
End Sub

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Sub Düzenle()
Set s1 = Sheets("Veri")
Set s2 = Sheets("Çalışma Sayfası")
s1.[k1:k100].ClearContents
s2.[a1:d1000].ClearContents
s2.Range("a1:d1000").Font.Bold = False
s1.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s1.Range("K1"), Unique:=True
s1.[a2].Select
sat = 0
For i = 2 To s1.[k65536].End(3).Row
s2.Cells(sat + 1, "a").Value = s1.Cells(1, "a").Value
s2.Cells(sat + 1, "b").Value = s1.Cells(1, "b").Value
s2.Cells(sat + 1, "c").Value = s1.Cells(1, "c").Value
s2.Cells(sat + 1, "d").Value = s1.Cells(1, "d").Value
s2.Range(s2.Cells(sat + 1, "a"), s2.Cells(sat + 1, "d")).Font.Bold = True
    For j = 2 To s1.[a65536].End(3).Row
        If s1.Cells(i, "k").Value = s1.Cells(j, "a").Value Then
            sat = s2.[a65536].End(3).Row + 1
            s2.Range(s2.Cells(sat, "a"), s2.Cells(sat, "d")).Value = s1.Range(s1.Cells(j, "a"), s1.Cells(j, "d")).Value
        End If
    Next j
Next i
Set s1 = Nothing
Set s2 = Nothing
MsgBox "Bitti"
End Sub

 

[Orion1]

Merhaba.
Sayın veyselemre hocam süper olmuş.
Ben bu Resize komutunu bilmiyorum.
Nerelerde kullanılır ve aşağıdaki komut ne diyor.Açıklarsanız memnun olurum.

a = sV.[A1].Resize(, 4).Value

 

[N.Ziya Hiçdurmaz]

yanıt

Sub aktar()
Set S1 = Sheets("Veri")
Set S2 = Sheets("Çalışma Sayfası")
For SUT = 1 To S1.[A65536].End(3).Row
If WorksheetFunction.CountIf(S1.Range("A2:A" & SUT), Range("A" & SUT).Value) = 1 Then
S = S + 1
S1.Range("G" & S & ":J" & S) = S1.Range("A" & SUT & ":D" & SUT).Value
End If
Next
For SUT = 1 To S1.[A65536].End(3).Row
For SUT1 = 1 To S1.[G65536].End(3).Row
If S1.Range("A" & SUT) = S1.Range("G" & SUT1) Then
SS = SS + 1
S2.Range("A" & SS & ":D" & SS) = S1.Range("A" & SUT & ":D" & SUT).Value
End If
Next
Next
[G2:J1000].ClearContents
S2.Select
[A2:D10000].Sort KEY1:=[A2], ORDER1:=xlAscending
End Sub

 

[AS3434]

5. seçenek

Sub sırala()
   Application.ScreenUpdating = False
    basla = Time
    Sheets("DENEME").[a:d].ClearContents
    Sheets("Veri").[A1:D10000].Copy
    Sheets("DENEME").Select
    [a1].PasteSpecial Paste:=xlPasteValues
    [A2:D10000].Sort KEY1:=[A2], ORDER1:=xlAscending, Key2:=[D2], Order2:=xlAscending
    For i = 2 To [d65536].End(3).Row + 1
    If Cells(i, 1) <> Cells(i + 1, 1) Then
    i = i + 1
    Rows(i).Insert Shift:=1
    End If
    Next
    z = Rows(1)
    For x = 2 To [A65536].End(3).Row
    If Range("a" & x) = "" Then Rows(x) = z
    Next
    [a1].Select
    bitis = Time
    MsgBox "Sorgulama Süresi: " & Format(bitis - basla, "hh:mm:ss")
End Sub

Sort etmeden demişsiniz, arkadaşlarda ona göre hazırlamış. Ama 9000 satırda aradaki
farkı görün diye tüm kodlar dosyada.

Bazı kodlar aynı yardımcı hücreleri kullandığı için karışıklık olmuş. Dosyayı yeniledim.

 

[veyselemre]

Ben bu Resize komutunu bilmiyorum.
Nerelerde kullanılır ve aşağıdaki komut ne diyor.Açıklarsanız memnun olurum.

a = sV.[A1].Resize(, 4).Value

Resize(RowSize, ColumnSize) formatında alanı yeniden boyutlandırıyor.
yukarıda a1 den itibaren 4 sütun (a1:d1) alanının değerini a dizisine atıyor. Kodları adım adım çalıştırırsanız işleyişini daha iyi anlarsınız.

 

[veyselemre]

Kodları biraz hızlandıralım.

Sub AktarHizli()
    basla = Time
    Application.ScreenUpdating = False
    Set sC = Sheets("Çalışma Sayfası")
    Set sV = Sheets("Veri")
    a = sV.[A1].Resize(, 4).Value
    sV.[H:K].Delete Shift:=xlUp
    sV.Columns("A:D").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=sV.[H1], Unique:=True
    son = sV.[H65536].End(3).Row
    sC.[a:d].Delete Shift:=xlUp
    sat = 1
    For x = 2 To son
        With sV.Cells(x, "H")
            say = WorksheetFunction.CountIf(sV.[A:A], .Resize())
            b = .Resize(, 4).Value
            With sC.Cells(sat, 1).Resize(, 4)
                .Value = a
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .Offset(1).Resize(say, 4).Value = b
                sat = sat + say + 1
            End With
        End With
    Next x
    sV.[H:K].Delete Shift:=xlUp
    Erase a, b
    Set sC = Nothing
    Set sV = Nothing
    bitis = Time
    Application.ScreenUpdating = True
    MsgBox "Sorgulama Süresi: " & Format(bitis - basla, "hh:mm:ss")
End Sub

 

[mavisachal]

Arkadaşlar,

Oncelikle yapmış oldugunuz çalışmalar için çok teşekkür ederim. Bu kadar

ugras verdiginiz icin gercekten cok müteşekkirim.

Benim şimdiye kadar uygulama şansım olmadı şimdi uygulamayı yapacağım. Eğer

bir sorunum olursa buraya tekrar yazarım.

Allah hepinizden razı olsun şu mübarek kandil gününde.

Hayırlı kandiller herkese.