süzülen verileri aktarma

K

kemal turan

Altın Üye
Katılım
10 Haziran 2011
Mesajlar
1,672
Excel Vers. ve Dili
Excel 2010 32 bit
Altın Üyelik Bitiş Tarihi
06-10-2032
merhaba,
Detaylı açıklamayı örnek dosyada yaptım.
Filtrelenen verilerin istenilen şekilde diğer sahifeye aktarılmasına ihtiyacım var.
Ben ustaların alıntılarından yaptım fakat veriler çok olduğundan çok uzun sürüyor.
Teşekekkür ederim.
 

Ekli dosyalar

K

kemal turan

Altın Üye
Katılım
10 Haziran 2011
Mesajlar
1,672
Excel Vers. ve Dili
Excel 2010 32 bit
Altın Üyelik Bitiş Tarihi
06-10-2032
Aşağıdaki kodlarla yapmak istediğimiz yapabiliyorum.
Daha hızlı bir kod olabilirmi
Kod: 
Sub Dikdörtgen1_Tıklat()
Application.ScreenUpdating = False
UserForm1.Show 0
ALIS
NAKIT
TAKSIT
Application.ScreenUpdating = True
Unload UserForm1
MsgBox "Bitti"

End Sub
Sub ALIS()
Set S1 = Sheets("STOK KARTLARI")
Set s2 = Sheets("fıyat")
Sheets("FIYAT").Select
   
    Range("A5:G19187").Select
    Selection.ClearContents
    Range("H1").Select
For i = 2 To S1.Range("H65536").End(3).Row
If S1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("A65536").End(3).Row + 1
s2.Cells(SONSTR, 1).Value = S1.Cells(i, 7).Value
s2.Cells(SONSTR, 2).Value = "TR"
s2.Cells(SONSTR, 3).Value = ""
s2.Cells(SONSTR, 4).Value = 1
s2.Cells(SONSTR, 5).Value = Date
s2.Cells(SONSTR, 6).Value = "TRY"
s2.Cells(SONSTR, 7).Value = S1.Cells(i, 11).Value
End If
Next i

End Sub
Sub NAKIT()
Set S1 = Sheets("STOK KARTLARI")
Set s2 = Sheets("fıyat")
For i = 2 To S1.Range("H65536").End(3).Row
If S1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("A65536").End(3).Row + 1
s2.Cells(SONSTR, 1).Value = S1.Cells(i, 7).Value
s2.Cells(SONSTR, 2).Value = "TR"
s2.Cells(SONSTR, 3).Value = ""
s2.Cells(SONSTR, 4).Value = 7
s2.Cells(SONSTR, 5).Value = Date
s2.Cells(SONSTR, 6).Value = "TRY"
s2.Cells(SONSTR, 7).Value = S1.Cells(i, 13).Value
End If
Next i

End Sub
Sub TAKSIT()
Set S1 = Sheets("stok kartları")
Set s2 = Sheets("fıyat")
For i = 2 To S1.Range("H65536").End(3).Row
If S1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("A65536").End(3).Row + 1
s2.Cells(SONSTR, 1).Value = S1.Cells(i, 7).Value
s2.Cells(SONSTR, 2).Value = "TR"
s2.Cells(SONSTR, 3).Value = ""
s2.Cells(SONSTR, 4).Value = 8
s2.Cells(SONSTR, 5).Value = Date
s2.Cells(SONSTR, 6).Value = "TRY"
s2.Cells(SONSTR, 7).Value = S1.Cells(i, 14).Value
End If
Next i
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,784
Excel Vers. ve Dili
Microsoft 365 Tr-64
Süzme işlemini de hiç yapmadan,
Süzülecek verileri Fiyat Yükleme sayfanızda I2 den itibaren aşağıya doğru istediğizin kadar listeleyerek

Formüllerle çözüm için, fiyat yükleme sayfanızda 2.satırdan itibaren aşağıdaki formülleri aşağı doğru istediğiniz kadar çoğaltabilirsiniz.

A sütunu
=EĞERHATA(KAYDIR(ÜRÜNLER!$A$1;KAÇINCI(DOLAYLI(ADRES(1+YUVARLA(SATIR()/3;0);9;1;1));ÜRÜNLER!$B$2:$B$1000;0);0;1;1);"")

B sütunu
=EĞER(A2<>"";"TR";"")

C..boş istemişsiniz

D sütunu
=EĞER(A2="";"";EĞER(MOD(SATIR()-1;3)=1;1;EĞER(MOD(SATIR()-1;3)=2;7;8)))

E sütunu (tarihi de nasıl aldığınızı yazarsanız o da dinamik olabilir)
=EĞER(A2="";"";TARİH(2021;1;31))

F sütunu
=EĞER(A2<>"";"TRY";"")

G sütunu
=EĞERHATA(KAYDIR(ÜRÜNLER!$A$1;KAÇINCI(A2;ÜRÜNLER!$A$2:$A$100;0);EĞER(D2<7;4;D2-1);1;1);"")
 
ÖmerFaruk

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,784
Excel Vers. ve Dili
Microsoft 365 Tr-64
Formüllü sonucun ekran görüntüsü
224926
 
K

kemal turan

Altın Üye
Katılım
10 Haziran 2011
Mesajlar
1,672
Excel Vers. ve Dili
Excel 2010 32 bit
Altın Üyelik Bitiş Tarihi
06-10-2032
Sn. NextLevel merhaba,
İlgi ve cevabınız için teşekkür ederim.
İsteğim aslında aynı çalışma kitabındaki diğer sayfaya verileri aktarma değildi.
Ben bu kodla kapalı başka bir dosyaya verileri aktarıp oradan nebim programında dış veri alma ile fiyatları güncellemesi amacım. Onun için for döngüsü ile kodlu bir çözüm gerekiyordu.
Çözümü yapabildim. Daha hızlı olabilirmi diye ustalarımızdan yardım istedim.
Kapalı dosyaya veri göndermek için oluşturduğum ve çalışan kodu aşağıdadır.
Kod: 
Sub Dikdörtgen1_Tıklat()
Application.ScreenUpdating = False
UserForm1.Show 0
ALIS
NAKIT
TAKSIT
Application.ScreenUpdating = True
Unload UserForm1
MsgBox "Bitti"
End Sub
Sub ALIS()
ChDir "C:\Users\USER\Desktop\KSM ÜRÜN STOK KARTLARI VE FİYATLAR"
    Workbooks.Open Filename:= _
        "C:\Users\USER\Desktop\KSM ÜRÜN STOK KARTLARI VE FİYATLAR\ProductBasePrices TEMEL FİYAT ŞABLONU.xlsx"
Set s1 = Workbooks("InventoryProducts stok ve fiyatlar.xlsx").Sheets("stok kartları")
Set s2 = Workbooks("ProductBasePrices TEMEL FİYAT ŞABLONU.xlsx").Sheets("Table1")
Sheets("Table1").Select
    Sheets("Table1").Range("A2:G19187").Select
    Selection.ClearContents
    Sheets("Table1").Range("H1").Select
     For i = 2 To s1.Range("A10000").End(3).Row
If s1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("A65536").End(3).Row + 1
s2.Cells(SONSTR, 1).Value = s1.Cells(i, 7).Value
s2.Cells(SONSTR, 2).Value = "TR"
s2.Cells(SONSTR, 3).Value = ""
s2.Cells(SONSTR, 4).Value = 1
s2.Cells(SONSTR, 5).Value = Date
s2.Cells(SONSTR, 6).Value = "TRY"
s2.Cells(SONSTR, 7).Value = s1.Cells(i, 11).Value
End If
Next i
End Sub
Sub NAKIT()
Set s1 = Workbooks("InventoryProducts stok ve fiyatlar.xlsx").Sheets("stok kartları")
Set s2 = Workbooks("ProductBasePrices TEMEL FİYAT ŞABLONU.xlsx").Sheets("Table1")
Sheets("Table1").Select
     For i = 2 To s1.Range("A10000").End(3).Row
If s1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("A65536").End(3).Row + 1
s2.Cells(SONSTR, 1).Value = s1.Cells(i, 7).Value
s2.Cells(SONSTR, 2).Value = "TR"
s2.Cells(SONSTR, 3).Value = ""
s2.Cells(SONSTR, 4).Value = 7
s2.Cells(SONSTR, 5).Value = Date
s2.Cells(SONSTR, 6).Value = "TRY"
s2.Cells(SONSTR, 7).Value = s1.Cells(i, 13).Value
End If
Next i

End Sub
Sub TAKSIT()
Set s1 = Workbooks("InventoryProducts stok ve fiyatlar.xlsx").Sheets("stok kartları")
Set s2 = Workbooks("ProductBasePrices TEMEL FİYAT ŞABLONU.xlsx").Sheets("Table1")
Sheets("Table1").Select
     For i = 2 To s1.Range("A10000").End(3).Row
If s1.Cells(i, 1).EntireRow.Hidden = False Then
SONSTR = s2.Range("A65536").End(3).Row + 1
s2.Cells(SONSTR, 1).Value = s1.Cells(i, 7).Value
s2.Cells(SONSTR, 2).Value = "TR"
s2.Cells(SONSTR, 3).Value = ""
s2.Cells(SONSTR, 4).Value = 8
s2.Cells(SONSTR, 5).Value = Date
s2.Cells(SONSTR, 6).Value = "TRY"
s2.Cells(SONSTR, 7).Value = s1.Cells(i, 14).Value
End If
Next i
ActiveWorkbook.Save
    ActiveWindow.Close
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,733
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Çok olan veriniz de deneyip süreyi bildirirseniz sevinirim.

C++: 
Option Explicit

Sub Filtreli_Verileri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, Say As Long, Zaman As Double
    Dim Sutun As Variant, Fiyat_Kodu As Variant, Son As Long, Veri As Variant, X As Long, Y As Byte
    
    Zaman = Timer
    
    Application.ScreenUpdating = 0
    
    Set S1 = Sheets("ÜRÜNLER")
    Set S2 = Sheets("FIYAT YUKLEME")
    
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Data").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    Sheets.Add , Sheets(Sheets.Count)
    Set S3 = ActiveSheet
    S3.Name = "Data"
    S2.Select
    
    Sutun = Array(5, 7, 8)
    Fiyat_Kodu = Array(1, 7, 8)
    
    S2.Range("A2:G" & S2.Rows.Count).ClearContents
    
    If S1.AutoFilterMode Then
        Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
        If Son > 1 Then
            S1.Range("A1").CurrentRegion.Copy S3.Range("A1")
            Veri = S3.Range("A2:H" & S3.Cells(S3.Rows.Count, 1).End(3).Row).Value
            
            ReDim Liste(1 To UBound(Veri, 1) * 3, 1 To 7)
            
            For X = LBound(Veri, 1) To UBound(Veri, 1)
                For Y = 0 To 2
                    Say = Say + 1
                    Liste(Say, 1) = Veri(X, 1)
                    Liste(Say, 2) = "TR"
                    Liste(Say, 3) = ""
                    Liste(Say, 4) = Fiyat_Kodu(Y)
                    Liste(Say, 5) = DateSerial(2021, 1, 31)
                    Liste(Say, 6) = "TRY"
                    Liste(Say, 7) = Veri(X, Sutun(Y))
                Next
            Next
        End If
    End If

    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Data").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    Application.ScreenUpdating = 1

    If Say > 0 Then
        S2.Range("A2").Resize(Say, 7) = Liste
        MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun veri bulunamadı!", vbCritical
    End If

    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
End Sub
 
K

kemal turan

Altın Üye
Katılım
10 Haziran 2011
Mesajlar
1,672
Excel Vers. ve Dili
Excel 2010 32 bit
Altın Üyelik Bitiş Tarihi
06-10-2032
Merhaba Korhan hocam ,
6200 satırı , 18000 satır olarak aktardı.
61 sn mükemmel sonuç.
Çok teşekkür ederim.
Selametle kalınız
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,733
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Tekrar Merhaba,

Ben şimdi ÜRÜNLER sayfasındaki verilerinizi 32.000 satıra kadar çoğalttım. 3 ürün filtreledim.

İşlem süresi yaklaşık 0,7 saniye sürüyor. Sizde o kadar sürmesi biraz garip geldi.

Dosyanızda formül yoğunluğu nedir?

Denediğim sistem;

8 GB Ram
İ5 6. Nesil İşlemci
Ofis 2010 32 Bit
 
K

kemal turan

Altın Üye
Katılım
10 Haziran 2011
Mesajlar
1,672
Excel Vers. ve Dili
Excel 2010 32 bit
Altın Üyelik Bitiş Tarihi
06-10-2032
Korhan hocam merhaba
Yanlış yazmışım O,61 sn.dir.
Vaktinizi aldım. Kusura bakmayın.
Teşekkür eder hayırlı günler dilerim.
Selametle
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst