4 veriyi suzerek baska sheete o dataları aktarmak

[kayra75]

Merhabalar,

Arkadaslar ekte bulunan örnek dosyadaki B sutunundan sadece e,f,g,j, lleri ayırarak sheet2 ye kopyalamayı yapmaya çalışıyorum. Autofilterda sadece iki tane koşullamaya izin veriyor bu konuyla ilgili bir kod varmıdır Makro içerisinde tanımlayarak yapalım bu konuyla ilgili yardımlarınızı rica ediyorum.
Simdiden cok tskler.

 

[mesudiye_052]

Selam;

Özet tablo ile yapılmış bir çalışma

 

[Orion1]

Dosyanız ektedir.
Gelişmiş filter uyguladım.

Sub adancedfilter()
Sheets("Sheet2").Range("A1:D65536").ClearContents
Range("A1:D" & Cells(65536, "B").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
        "F1:I5"), CopyToRange:=Range("K1:N1"), Unique:=False
Range("K1:N" & Cells(65536, "L").End(xlUp).Row).Cut
Sheets("sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
MsgBox "Filtreleme başarı ile yağıldı" & vbLf & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub

 

[kayra75]

Merhaba Evren,
Öncelikle kod icin tsk ederim. Yanlız sanırım Sheet1 de bu listelenecek kriterleri yazmak gerekiyor. Kriterleri Kodda yazarak yapmam mumkunmudur ?

 

[kayra75]

Merhabalar tekrar,
B sutununda bulunan bölge unsuru surekli değişmeyen yada cok nadir değişebilen verilerden oluşuyor. B sutununda ayrımını yaparak aktarmak istediğimiz datanın listeleme kriterini acaba sadece koda yazmamız mumkunmudur

 

[Orion1]

Merhabalar tekrar,
B sutununda bulunan bölge unsuru surekli değişmeyen yada cok nadir değişebilen verilerden oluşuyor. B sutununda ayrımını yaparak aktarmak istediğimiz datanın listeleme kriterini acaba sadece koda yazmamız mumkunmudur

Bu yötem en hızlı yöntemdir.
Verieliriniz çok olduğunu 10 bin 20 bin gibi varsayarsak.bu yöntemin hzızına hiç bir i gelemez.
Yinede başka yöntemle yapılmasını isterseniz.Yaparım .Ama o yöntemler çok veri olduğu zaman kaplumbağa ile tavşan misali olrlar.Bunuda size hatırlatayım.

 

[usubaykan]

Merhaba,

Dosya içerisinde ki Sheet1 de dolgu rengi olan satırlara göre veri aktarımı yapılmaktadır. Altarnetif olarak dosyayı inceleyiniz.

Sub Filtre()
Dim S1 As Worksheet, S2 As Worksheet, Sütun As Byte, U As Long, Satır As Long, S As Long
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    
    Application.ScreenUpdating = False
    
    S2.Range("A2:D65536").ClearContents
    
        For Sütun = 6 To S1.Cells(1, 256).End(1).Column
            With Sheets("Sheet1")
            .Range("B1").AutoFilter
                U = S2.[B65536].End(3).Row
                Satır = U + 1
                    .Range("B1").AutoFilter Field:=2, Criteria1:=S1.Cells(1, Sütun)
                     S = S1.[B65536].End(3).Row
                     If S <> 1 Then
                     .Range("A2" & ":D" & S).Copy
                    S2.Range("A" & Satır).PasteSpecial
                    .Range("A1").Select
                Application.CutCopyMode = False
                .Range("B1").AutoFilter
            End If
            End With
        Next
        
    S2.Select
    Range("A1").Select
    
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır", vbInformation, "MiCrOSoft ExCeL"
End Sub

 

[Orion1]

Buyurun auto filter ile sayfada gözükmğüyor.Daha doğrusu sonradan siliniyor.

Sub otofilter()
Sheets("Sheet2").Range("A2:D65536").ClearContents
z = filter("e")
z = filter("f")
z = filter("g")
z = filter("j")
Sheets("sheet2").Range("F1:I65536").ClearContents
MsgBox "Filtreleme başarı ile yağıldı" & vbLf & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"

End Sub
Function filter(deg As String)
Sheets("sheet2").Range("F1:I65536").ClearContents
Range("A1").AutoFilter field:=2, Criteria1:="=" & deg
Range("A2:D65536").CurrentRegion.Copy Sheets("sheet2").Range("F1")
Sheets("sheet2").Range("F2:I" & Sheets("Sheet2").Cells(65536, "F").End(xlUp).Row).Copy Sheets("sheet2"). _
Range("A" & Sheets("Sheet2").Cells(65536, "A").End(xlUp).Row + 1)
Range("A1").AutoFilter
End Function