Listedeki bazı bilgileri başka bir sayfaya aktarma

[sakoz]

Merhabalar ,

Bir makro sayesinde ekte gönderdiğim dosyadaki listeyi elde ediyoruz..
Bu listede A sütununda POZ.NO , B sütununda VARIŞ YERi , C sütununda İrsaliye Tarihi , D sütununda OTO ADEDİ , E sütununda ise GÜZERGAH KM bilgileri vardır..
Yapılmak istenen ise ; A sütunundaki Poz.nosu aynı olanları buradan alıp başka bir sayfaya aktarmasıdır.
Örnek : 28421 listede 2 tane vardır...Bunun gibi olanları alıp başka bir sayfaya aktaracak.
ilgilenen herkese şimdiden teşekkür ederim..

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub aktar()
Dim s2 As Worksheet
Dim sat, s As Integer
Set s2 = Sheets("Sayfa2")
s2.[a2:e1000].Clear
s = 2
For sat = 2 To Cells(65536, "a").End(xlUp).Row
If WorksheetFunction.CountIf(Range("a2:a" & sat), Cells(sat, "a")) > 1 Then
Range(Cells(sat, "a"), Cells(sat, "e")).Copy Range(s2.Cells(s, "a"), s2.Cells(s, "e"))
s = s + 1
End If: Next
End Sub

 

[Ferhat Pazarçevirdi]

Alternatif olarak aşağıdaki kodları da kullanabilirsiniz. Daha büyük datalar için, hızlı sonuç alırsınız.

Örnek dosyayı inceleyiniz.

Sub Aynilari_Bul_Ayikla()
    Dim rsKaynak As ADOR.Recordset
    Dim rsHedef As ADOR.Recordset
    Dim rng As Range
    Dim rngAlan As Range
    
    Set rsKaynak = New ADOR.Recordset: Call RS_Ayarla(rsKaynak)
    Set rsHedef = New ADOR.Recordset: Call RS_Ayarla(rsHedef)
    
    Set rngAlan = Range("A2:E" & Cells(65536, 1).End(xlUp).Row)
    
        
    With rsKaynak
        For Each rng In rngAlan.Cells
            If rng.Column = 1 Then .AddNew
            .Fields(rng.Column - 1) = rng
        Next
        .MoveFirst
        
        Do Until .RecordCount = 0
            .Filter = .Fields(0).Name & "=" & Trim(.Fields(0).Value)
            If .RecordCount > 1 Then
                .MoveFirst
                Do Until .EOF
                    rsHedef.AddNew
                    For i = 0 To .Fields.Count - 1
                        rsHedef.Fields(i) = .Fields(i)
                    Next i
                    .Delete adAffectCurrent
                    .MoveNext
                Loop
            Else
                .Delete adAffectCurrent
            End If
            .Filter = ""
            If .RecordCount > 0 Then .MoveFirst
            
        Loop
    End With
    
    If rsHedef.RecordCount > 0 Then
        rsHedef.MoveFirst
    End If
    
    With Sheets("Sayfa2")
        .Columns("A:E").Delete
        .Range("A1").CopyFromRecordset rsHedef
        .Select
    End With
    
    Set rsKaynak = Nothing
    Set rsHedef = Nothing
    Set rngAlan = Nothing
End Sub
[COLOR=green]'-----------------------[/COLOR]
Private Sub RS_Ayarla(rs As ADOR.Recordset)
    With rs
        With .Fields
            .Append "Poz_No", adChar, 50
            .Append "Varis_Yeri", adChar, 50
            .Append "Irsaliye_Tarihi", adDate
            .Append "Oto_Adedi", adDouble
            .Append "Guzergah", adDouble
        End With
        .CursorLocation = adUseClient
        .CursorType = adOpenForwardOnly
        .Open
    End With
End Sub

 

[hsayar]

hocam gerçi burası yer değil ama ADOB ile ADOR arasındaki fark nedir?

 

[sakoz]

Ziya hocam ve Ferhat Hocam ,
Verdiğiniz cevaplar için , ikinizede ayrı ayrı teşekkür ederim...Emeginize ve ellerinize sağlık...Tekrar teşekkürler.
Ayrıca bu listeyi almamızı sağlayan Zeki Gürsoy hocamada teşekkürler.

 

[Ferhat Pazarçevirdi]

hocam gerçi burası deği ama ADOB ile ADOR arasındaki fark nedir?

Hüseyin bey,

Microsoft'un ADO teknolojisinde (paketinde) ADODB ve ADOR'nin de dışında birçok kolaylık sağlanmış durumda ... Örneğin;

1. ADODB : MS Activex Data Object
Bununla, bilinen tüm Veritabanı işlemlerini yürütebilirsiniz. Her nerede olursa olsun herhangi bir Veritabanına bağlanabilir (ADODB.Connection), bunun üzerinde hertürlü SQL sorgusunu çalıştırıp işlemler yürütebilirsiniz. Bilgileri, ADODB.Recorset'ine atabilir, bu recordset üzerinde istediğiniz işlemleri yapabilirsiniz.

Hem Datalar hem de VT yapısı ile ilgilenir.

2. ADOR : MS Activex Data Object RecordSet
Sadece Recordset nesnesi üzerinde işlem yapmanızı sağlayan bir araçtır.. Örneğin, programınızı yazarken, çok sayıda verinin işlemden geçirilmesi gerektiğini düşünün. Bunun için; VBA'da temel olarak dizi veya colleksiyonlara başvurursunuz. Ama, Dizi ve kolleksiyonların içinde, veriyi süzme, sıralama, gruplama, silme, yer değiştirme işlemleri oldukça meşakkatlidir. Oysa, aynı işlemleri ADOR referansı ile oluşturduğunuz bir RecordSet nesnesinde çok rahat yapabilirsiniz.

Ayrıca oluşturacağınız RecordSet'i istediğiniz gibi boyutlandırma ve alan tiplerini belirleme şansınız var ..

Yani, tamamen Datalar üzerinde işlem yapar ...

3. ADOX : MS ADO Ext 2.X For DLL and Security
Bu ise, bir Veritabanını yaratmaktan, varolan bir Veri tabanının yapısını değiştirmeye kadar her işin üstesinden gelen bir komponentir.

Yani, datalarla değil, direkt olarak VT yapısıyla ilgilenir.

4. ADOMD : MS Activex Data Object (MultiDimensional) gibi ...
Bunu ben de kullanmadım ama Excel'deki Pivot tablo gibi çok boyutlu datalar üzerinde işlem yapabildiğini biliyorum ...

 

[hsayar]

Ferhat hocam açıklayıcı bilgileriniz için çok teşekkür ederim. İşlerimi daima kolaylaştırdınız. Allah sizden razı olsun.

 

[sakoz]

Merhabalar ,

Ferhat Bey'in yaptığı makro çok güzel çalışıyor...Sayfa1'den poz.nosu aynı olan birden fazla kayıtları alıp sayfa2'ye kopyalıyor...Burada şunu yapabilirmiyiz veya nasıl yapabiliriz...Sayfa2 'ye kopyaladıkları kayıtları Sayfa1'den tamamen sildirebilirmiyiz..
Teşekkürler...

 

[Ferhat Pazarçevirdi]

Bu işlem için aşağıdaki kodu kullanabilrisiniz. Sayfa1'deki satırlar teker teker silinmedi için de, hız anlamında daha rahat çalışırsınız.

Sub Aynilari_Bul_Ayikla()
    
    Dim rsKaynak As ADOR.Recordset
    Dim rsHedef As ADOR.Recordset
    Dim rng As Range
    Dim rngAlan As Range
    Dim i As Integer
    Dim x As Integer
    
    Set rsKaynak = New ADOR.Recordset: Call RS_Ayarla(rsKaynak)
    Set rsHedef = New ADOR.Recordset: Call RS_Ayarla(rsHedef)
    
    Set rngAlan = Range("A2:E" & Cells(65536, 1).End(xlUp).Row)
    
    With rsKaynak
        For Each rng In rngAlan.Cells
            If rng.Column = 1 Then
                .AddNew
                .Fields(.Fields.Count - 1) = rng.Row
            End If
            .Fields(rng.Column - 1) = rng
        Next
        .MoveFirst
        
        Do Until .RecordCount = 0
            .Filter = .Fields(0).Name & "=" & Trim(.Fields(0).Value)
            If .RecordCount > 1 Then
                .MoveFirst
                Do Until .EOF
                    rsHedef.AddNew
                    For i = 0 To .Fields.Count - 1
                        rsHedef.Fields(i) = .Fields(i)
                    Next i
                    .Delete adAffectCurrent
                    .MoveNext
                Loop
            Else
                .Delete adAffectCurrent
            End If
            .Filter = ""
            If .RecordCount > 0 Then .MoveFirst
            
        Loop
    End With
    
    If rsHedef.RecordCount > 0 Then
        rsHedef.MoveFirst
    End If
    
    Application.Calculation = xlCalculationManual
    
    With Sheets("Sayfa2")
        .Columns("A:E").Delete
        .Range("A1").CopyFromRecordset rsHedef
    End With
    
    Set rng = Nothing: Set rngAlan = Nothing
    
    If rsHedef.RecordCount > 0 Then
        
        With rsHedef
            .MoveFirst
            Do Until .EOF
                x = x + 1
                If x = 1 Then
                    Set rngAlan = Rows(.Fields(.Fields.Count - 1))
                Else
                    Set rngAlan = Application.Union(Rows(.Fields(.Fields.Count - 1)), rngAlan)
                End If
                .MoveNext
            Loop
        End With
        
        If Not rngAlan Is Nothing Then
            rngAlan.Delete
        End If
    
    End If
    
    Sheets("Sayfa2").Select
        
    Application.Calculation = xlCalculationAutomatic
    
    Set rsKaynak = Nothing
    Set rsHedef = Nothing
    Set rng = Nothing
    Set rngAlan = Nothing
    
End Sub
Private Sub RS_Ayarla(rs As ADOR.Recordset)
    With rs
        With .Fields
            .Append "Poz_No", adChar, 50
            .Append "Varis_Yeri", adChar, 50
            .Append "Irsaliye_Tarihi", adDate
            .Append "Oto_Adedi", adDouble
            .Append "Guzergah", adDouble
            .Append "Satir", adDouble
        End With
        .CursorLocation = adUseClient
        .CursorType = adOpenForwardOnly
        .Open
    End With
End Sub

 

[sakoz]

Ferhat Hocam size ne kadar teşekkür etsem azdır...Bu arada ben aslında macro yazmayı ögrenmek istiyorum...bununla ilgili olarak beni yönlendirirseniz beni çok mutlu etmiş olursunuz..
Saygılar...

 

[Ferhat Pazarçevirdi]

Eğer reklam olarak algılamazsanız, forumda tanıtılan bir kitap var "Enine Boyuna Excel 2003 Programlama" diye ... Bu linkten inceleyebilirsiniz.

Bu ve benzeri başlangıç düzeyi VBA programlama kitapları; size ilk başta yön verecek ve işin temellerini ve mantığını gösterecektir. Geri kalan şey ise, bunların uygulama örneklerini forumda veya web'de sürekli araştırmanızla ilişkili ...

Bir müddet sonra "Dim" neymiş?, "For" neymiş? gibi şeylerden arınıp, kodlara farklı bir gözle bakmaya ve kendi ihtiyaçlarınızı karşılayabilen basit kodlar yazmaya başlayacaksınız.

Sonrasında ise, işin kurdu olur çıkarsınız

Forumda; -genelde- biz lalettayin bir düzende, sorulara verdiğimiz cevaplarla belirli bir düzeyi hedeflemekteyiz. Ama "Dersane" kısmında, işin temellerini anlatan çok değişik ve anlaşılabilir örnek çalışmalar var ... Onları da inceleyiniz.

Ama öncelikli olarak bir kitabın, programatik yaklaşımı, sizi hedefe daha hızlı vardırır...

 

[sakoz]

Ferhat Bey önerileriniz icin teşekkürler...Biryerlerden başlamak iyi olacaktır benim icin...Tekrar teşekkürler...Bu arada Sizde İzmir'de oturuyorsunuz sanırım...Eğer yanlış anlamazsanız msn adresim slmakoz@hotmail.com
İyi çalışmalar dilerim...

 

[Ferhat Pazarçevirdi]

Ben hiç dikkat etmedim bulunduğunuz şehire ... Meğerse, İzmir'liymişsiniz ... İzmir, her zaman bir başkadır ... İletişim adresim benim de profilim de bulunmakta ... Sevgiler ...

 

[sakoz]

Ferhat Bey Merhabalar ,

Şimdi yeni bir liste çektim ve sizin yazmış oldugunuz makroyu bu yeni listeye uyguladım.Fakat Compile error : user-defined type not defined hatası verdi.Makro RS_AYARLA kısmında duruyor.
Problem ne olabilir acaba...? Yeni dosyada ektedir.
Teşekkürler..

 

[Ferhat Pazarçevirdi]

Kodları kopyalama usulü ile yeni bir kitaba monte edecekseniz, öncelikle şunu yapmalısınız.

Visual Basic Editörüne girip, menüden, Tools->References'e tıklayın. Karşısınıza çıkan listeden "Microsoft Activex Data Object Recordset 2.X Library" referansını işaretleyin ve tamam deyin. Kodları,şimdi, yeniden çalıştırmayı deneyin.

Bu refererans sadece eklendiği çalışma kitabına özgüdür.

 

[sakoz]

Evet Ferhat Bey ,

Yine hızır gibi yetiştiniz...Tekrar teşekkür ederim...Problem çözüldü...Sizede kolay gelsin...İyi çalışmalar...