Süzülen veriler Sayfa2'ye aktarılsın

[Hacı Bayram ÖZKAN]

Merhaba arkadaşlar, isteğimi ekli dosyamda anlatım, yardımcı olursanız sevinirim.
Ekli dosyam http://www.dosya.tc/server6/gb6xet/EVRAK_DENEME.xls.html
Teşekkürler

 

[Murat OSMA]

Aktardıktan sonra halletseniz daha basit olur. Bazen ters mantık kurmak işi hızlandırır.
Aktarma kodunuz var zaten.
O kodun altına Sayfa2.Range("B:B,F:G").Delete satırını ilave edin.​

 

[Hacı Bayram ÖZKAN]

Merhaba Osman bey, farkında iseniz iki tane kod var ama ikisi de benim isteğimi yapmıyor, bu kodları zaten siteden aldım, ama benim isteğimi karşılamadı, bu kodun birisini Korhan bey hazırlamış, sizin ilavenizi yaptım, ama Sayfa2 deki elde etmen gereken verileri alamadım.
Alternatif bir kod yokmu? Teşekkürler.

 

[Orion1]

Dosyanız linktedir.

DOSYAYI İNDİR

Private Sub CommandButton1_Click()
Dim sh As Worksheet, sonsat As Long, k As Range, sat As Long, adr As String
Set sh = Sheets("Sayfa2")
sh.Range("A2:G" & Rows.Count).ClearContents
sonsat = Cells(Rows.Count, "I").End(xlUp).Row
Set k = Range("I2:I" & sonsat).Find(ComboBox1.Value, , xlValues, xlWhole)
sat = 2
Application.ScreenUpdating = False
If Not k Is Nothing Then
    adr = k.Address
    Do
        sh.Cells(sat, "A").Value = Cells(k.Row, "A").Value
        sh.Cells(sat, "B").Value = Cells(k.Row, "C").Value
        sh.Cells(sat, "C").Value = Cells(k.Row, "D").Value
        sh.Cells(sat, "D").Value = Cells(k.Row, "E").Value
        sh.Cells(sat, "E").Value = Cells(k.Row, "H").Value
        sh.Cells(sat, "F").Value = Cells(k.Row, "G").Value
        sh.Cells(sat, "G").Value = Cells(k.Row, "I").Value
        sat = sat + 1
        Set k = Range("I2:I" & sonsat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
End If
Set k = Nothing
If Not IsDate(TextBox1.Value) Then GoTo atla
Set k = Range("D2:D" & sonsat).Find(CDate(TextBox1.Value), , xlValues, xlWhole)
Application.ScreenUpdating = False
If Not k Is Nothing Then
    adr = k.Address
    Do
        sh.Cells(sat, "A").Value = Cells(k.Row, "A").Value
        sh.Cells(sat, "B").Value = Cells(k.Row, "C").Value
        sh.Cells(sat, "C").Value = Cells(k.Row, "D").Value
        sh.Cells(sat, "D").Value = Cells(k.Row, "E").Value
        sh.Cells(sat, "E").Value = Cells(k.Row, "H").Value
        sh.Cells(sat, "F").Value = Cells(k.Row, "G").Value
        sh.Cells(sat, "G").Value = Cells(k.Row, "I").Value
        sat = sat + 1
        Set k = Range("D2:D" & sonsat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
End If
Set k = Nothing
atla:
Application.ScreenUpdating = True

sh.Select
Set sh = Nothing
Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim sonsat As Long, i As Long
sonsat = Cells(Rows.Count, "I").End(xlUp).Row
For i = 2 To sonsat
    If WorksheetFunction.CountIf(Range("I2:I" & i), Cells(i, "I").Value) = 1 Then
        ComboBox1.AddItem Cells(i, "I").Value
    End If
Next i
If ComboBox1.ListCount > 0 Then ComboBox1.ListIndex = 0
End Sub

 

[Hacı Bayram ÖZKAN]

Evren bey eline sağlık güzel olmuş, fazlasını yapmışsınız, burada ikinci süzme işlemini de yaptıra bilirmiyim, yani birinci süzden sonra ikinci süzülen bu verilerin altından devam etsin. Teşekkürler.

 

[Orion1]

Evren bey eline sağlık güzel olmuş, fazlasını yapmışsınız, burada ikinci süzme işlemini de yaptıra bilirmiyim, yani birinci süzden sonra ikinci süzülen bu verilerin altından devam etsin. Teşekkürler.

dosyayı güncelledim.

4 nolu mesajdan indirebilirsiniz.
Not: D sütununda bazı veriler tarih görünümünde metindir.
Bu yüzden onları listelemeyebilir.

 

[Hacı Bayram ÖZKAN]

Sayın abim, ben yanlış anlattım galiba; böyle değilde, şöyle anlatmaya çalışayım.
İlk yaptığın gibi ancak malmüdürlüğünü süzdükten sonra, akedaşı süzdüğüm zaman, malmüdürlüğünün bittiği yerden akedaş devam edecek, yani böylelikle bir kaç kurumu alt alta ekleyeceğim. Kurusa bakma saygılarımla...

 

[Orion1]

Sayın abim, ben yanlış anlattım galiba; böyle değilde, şöyle anlatmaya çalışayım.
İlk yaptığın gibi ancak malmüdürlüğünü süzdükten sonra, akedaşı süzdüğüm zaman, malmüdürlüğünün bittiği yerden akedaş devam edecek, yani böylelikle bir kaç kurumu alt alta ekleyeceğim. Kurusa bakma saygılarımla...

Dosyanız linktedir.

DOSYAYI İNDİR

Private Sub CommandButton1_Click()
Dim sh As Worksheet, sonsat As Long, k As Range, sat As Long, adr As String
Set sh = Sheets("Sayfa2")
sonsat = Cells(Rows.Count, "I").End(xlUp).Row
Set k = Range("I2:I" & sonsat).Find(ComboBox1.Value, , xlValues, xlWhole)
sat = sh.Cells(Rows.Count, "A").End(xlUp).Row + 1
Application.ScreenUpdating = False
If Not k Is Nothing Then
    adr = k.Address
    Do
        sh.Cells(sat, "A").Value = Cells(k.Row, "A").Value
        sh.Cells(sat, "B").Value = Cells(k.Row, "C").Value
        sh.Cells(sat, "C").Value = Cells(k.Row, "D").Value
        sh.Cells(sat, "D").Value = Cells(k.Row, "E").Value
        sh.Cells(sat, "E").Value = Cells(k.Row, "H").Value
        sh.Cells(sat, "F").Value = Cells(k.Row, "G").Value
        sh.Cells(sat, "G").Value = Cells(k.Row, "I").Value
        sat = sat + 1
        Set k = Range("I2:I" & sonsat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
End If
Set k = Nothing
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
Unload Me
End Sub

 

[Hacı Bayram ÖZKAN]

Abi eline sağlık zahmet verdim iyi akşamlar dua ile kal.

 

[Orion1]

Abi eline sağlık zahmet verdim iyi akşamlar dua ile kal.

Rica ederim.
İyi çalışmalar.