• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Özet sayfasına aktar

Kod: 
Sub Askm_Aktar()
Dim s1, s2, sayfa As Worksheet
Dim Str, SonSat As Long
Set s1 = Sheets("ÖZET AKTAR")
Str = 2
s1.Range("A2:F1000000").ClearContents
For Each sayfa In Worksheets
If sayfa.Name <> "ÖZET AKTAR" Then
    SonSat = Worksheets(sayfa.Name).Range("A65536").End(xlUp).Row
    For i = 2 To SonSat
        If Worksheets(sayfa.Name).Cells(i, "F").Text = "YANLIŞ" Then
            s1.Cells(Str, "A") = Worksheets(sayfa.Name).Cells(i, "A")
            s1.Cells(Str, "B") = Worksheets(sayfa.Name).Cells(i, "B")
            s1.Cells(Str, "C") = Worksheets(sayfa.Name).Cells(i, "C")
            s1.Cells(Str, "D") = Worksheets(sayfa.Name).Cells(i, "D")
            s1.Cells(Str, "E") = Worksheets(sayfa.Name).Cells(i, "E")
            s1.Cells(Str, "F") = Worksheets(sayfa.Name).Cells(i, "F")
            Str = Str + 1
        End If
    Next i
End If
Next
MsgBox "Aktarma işlemi tamamlandı..." & Chr(10) & Chr(10) & "İyi çalışmalar...", vbInformation, "ASKM"
End Sub
 
Merhaba.

Alternatif olsun.
Aktarma işlemi için, For..Next döngüsü yerine FİLTRE yöntemi kullanıldı.
Veri yığını büyüdüğünde filtre yöntemi daha hızlı sonuç verecektir.
.
Kod: 
[B]Sub OZETE_AKTAR()[/B]
Set oz = Sheets("ÖZET AKTAR")
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
oz.Cells.Clear: Sheets("ANASAYFA").[A1:F1].Copy oz.[A1]
oz.Cells(1, "G") = "KAYNAK": oz.[F1].Copy: oz.[G1].PasteSpecial Paste:=xlPasteFormats
For Each s In ThisWorkbook.Worksheets
    If s.Name <> "ÖZET AKTAR" Then
        s.Range("A1:F" & Rows.Count).AutoFilter Field:=6, Criteria1:="YANLIŞ"
        If s.Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
            sat = oz.Cells(Rows.Count, 1).End(xlUp).Row + 1
            s.Range("A2:F" & s.Cells(Rows.Count, 1).End(xlUp).Row).Copy
            oz.Cells(sat, 1).PasteSpecial Paste:=xlPasteValues
            oz.Range(oz.Cells(sat, 7), oz.Cells(oz.Cells(Rows.Count, 1).End(xlUp).Row, 7)) = s.Name
        End If
        s.Range("A1:F1").AutoFilter
    End If
Next
oz.Range("A1:G" & oz.Cells(Rows.Count, 1).End(xlUp).Row).Borders.LineStyle = xlContinuous
oz.Activate: oz.Columns.AutoFit: oz.[A1].Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]
 
Sayın askm,ve Ömer Bey çok teşekkür ederim kodlarınız denedim, Ömer beyin kodları söylediği gibi büyük verilerde çok hızlı,sayın askm kodlarınız sorunsuz fakat büyük verilerde yavaş çalışıyor,birde kodlara ilave olarak "Anasayfaya" "A" sütununda diğer sayfalarda olamayan, 1 part_no eklediğimde o part_no yu, ÜRÜN koduna bakarak, ilgili sayfaya kopyalaması mümkün mü?
 
Merhaba askm ve Ömer bey yardımcı olabilirmisiniz? kolay gelsin..
 
Son eklediğiniz ifadeyi örnek dosyanıza ekleyip anlatabilir misiniz.
 
Sayın askm kısaca söyle kodlar aktarım yaptıktan sonra , Tekrar çalışma kitabında "ANASAYFA" da "A" sütununu süzme işlemi yapıp,eğer "ANASAYFA" "A" sütununda olup diğer tüm sayfalarada olmayan bir kod varsa, o ürünü "ANASAYFA" "C" sütununda ki karşılığına bakıp örnek: MB ise MB sayfasına
LCD ise LCD sayfasına kopyalacak kolay gelsin.
 
Anasayfadaki A sütunundaki değerlerin tamamı AAAAAA şeklinde. Asıl örneği sakıncası yoksa bana mail ya da özelden atarsanız yardımcı olayım. Bu şekilde tüm veriler sayfalara gitmiş olacak zaten.
 
Merhaba sayın askm sizden şöyle bir istekte bulunmak istiyorum bu şekilde olursada işime yarayacak
"ANASAYFADA" bir ürün arama "userforumu" oluşturup ,ürün kodunu önce "ANASAYFA" da ara yoksa tüm sayfalarda ara bulursan üzerine git,eğer bulamazsan yeni kayıt oluştur diyip, "part_no" "part_name",Ürün," "SAĞ T", "Fiziki Adet" manuel girdikten sonra ürünü önce "Anasayfa" da en alt satıra,sonrada ürünün "ÜRÜN" koduna bakarak ilgili sayfa kopyalamasın istiyorum,kolay gelsin teşekkürler..
özet: ürün ara bul, bulursan üzerine git
bulamazsan yeni kayıt oluştur..
http://s9.dosya.tc/server3/59o54w/sayim.rar.html
 
Örnek dosyanızda userform istiyorsanız tasarımı yapıp yüklerseniz bakalım. Yok A1 de aramak istediğiniz alana ait başlık, B1 e de aranacak kelimeyi yazacak şekilde isterseniz ona göre yeniden yükleme yapın bakalım. Aranacak kelime hangisi olacak onu da belirtirseniz. Yani Part No da mı aranacak vb.
 
Sayın askm yapmak istediğim yeni gelen ürünü "user forum" üzerinde PART_NO olarak sayfalarda aratıp eğer varsa üzerine git eğer yoksa "PART_NO" ,VE "ÜRÜN" yeni ürün girişi yaparak hem anasayfaya hemde ilgili sayfaya kaydetmek,
özet: user forum üzerinde 6 adet başlık olacak ben hangi alanı doldurursam o bilgiler hem "anasayfa"
hemde ilgili "MB,LCD,BATARYA" gibi ürün sayfasına kayıt olacak..
 
Son düzenleme:
Bir label bir textbox için userform oluşturma mantığını anlamadım. Bunun yerine inputbox ile arama yaptırmak, ya da hücreye girilince arama yapması daha kolay olur sanırım.
 
selam kolay gelsin arkadaşlar gelsin arkadaşlar.
 
Son düzenleme:
Merhaba hayırlı geceler arkadaşlar ben Sayın "Ömer Baranın" kodların kullanarak sorunuma çözüm buldum ancak bir sorun daha var ki adetler değişince tekrar güncellemek yani yapmak istediğim "Özet Aktar" sayfasına verileri aktardıktan sonra değeri yanlış olan ürünleri "ÖZET AKTAR" sayfasında "FİZİKİ SAYIM" sütununda sayıp, "GÜNCELLE" butonuna basınca verileri "PART_NO" larına bakarak sayfalarda "FİZİKİ ADET" sütunlarında sayıları güncellemek istiyorum kolay gelsin teşekkürler..
Örnek : bu gün saydığım ürün fiziki adeti değiştikçe, kontrol edip sayıp adeti güncellemek amacım..

http://www.dosya.tc/server9/gv41p9/Sayim_2.rar.html
 
Merhaba.

Aşağıdaki kod'u kullanabilirsiniz.
.
Kod: 
[B]Sub SAYIM_AKTAR()[/B]
Set oz = Sheets("ÖZET AKTAR")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wf = Application.WorksheetFunction
    For satir = 2 To oz.Cells(Rows.Count, 1).End(xlUp).Row
        Set s = Sheets(oz.Cells(satir, 7).Value)
         If wf.CountIf(s.Range("A:A"), oz.Cells(satir, 1)) > 0 Then _
            s.Cells(wf.Match(oz.Cells(satir, 1), s.[A:A], 0), 5) = oz.Cells(satir, 8)
    Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı", vbInformation, "..::.. Ömer BARAN ..::.."
[B]End Sub[/B]
 
Merhaba Ömer Bey kodlarınız sorunsuz çalışıyor çok teşekkür ederim,sizden bir isteğim daha olcak "ANASAYFA" ya yeni bir ürün eklediğimde onu "ÜRÜN" özelliğine göre ilgili sayfaya otomatik eklemesi
örnek: "MB" ise "MB "LCD" ise "LCD" sayfasına kopyalaması kolay gelsin teşekkürler..
 
Merhaba Ömer bey yardımcı olabilirmisiniz? kolay gelisn teşekkürler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst