• DİKKAT

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

3 ihtimalli veri süz aktar

Merhaba,

Bu kodu deneyin.

Kod: 
Sub aktar()
Set s1 = Sheets("VERİ ")
Set s2 = Sheets("RAPOR")
a = s1.Range("A2:AL" & s1.Cells(Rows.Count, 1).End(3).Row)
Set d = CreateObject("scripting.dictionary")
    For i = 1 To UBound(a)
        If a(i, 38) = "BEKLİYOR" Then
            d(a(i, 1)) = a(i, 1)
        End If
    Next i
    If d.Count > 0 Then
        For i = 1 To UBound(a)
            For Each v In d.keys
                If a(i, 1) <> Empty And a(i, 1) <> v Then
                    say = say + 1
                    a(say, 1) = a(i, 1)
                    a(say, 2) = a(i, 38)
                End If
            Next v
        Next i
        s2.Range("A2:B" & Rows.Count).ClearContents
        s2.[A2].Resize(say, 2) = a
    End If
MsgBox "İşlem tamam.", vbInformation
End Sub
 
ADER_34' Alıntı:
Merhaba yusuf44,Ömer Bey,ve Halit bey öncelikle sabırlı yaklaşımınız için hepinize çok teşekkür ediyorum ve kodlarınızı denedim,VERİ sayfasında 1 rakamı örnektir ve değişkendir "BEKLİYOR" değeri içerdiği için aktarılmaması gerekiyor örnek dosyamı son halini değiştirip yüklüyorum hakkınızı helal edin yordum sizi umarım bu dosya açıklayıcı olur kolay gelsin..

http://s8.dosya.tc/server5/tc10ga/AKTAR_2.xlsx.html
Genişletmek için tıkla ...

Daha önce birkaç kez belirttiğim gibi 9. mesajdaki kodlar ilk verdiğiniz örnek dosyada verileriniz AI sütununda olduğu için istediğiniz şekilde herhangi bir kod hiçbir satırda BEKLİYOR değeri içermiyorsa ve ALINDI veya ALINACAK ise zaten istediğinizi yapıyor ve o satırları aktarıyordu. Yani kod örnek dosyanıza göre tam olarak istediğiniz kontrolü yapıyordu. Tek eksiği CL yerine AC sütununa kadar aktarıyordu.

Şimdiki örnek dosyanızda durum sütununu AL sütununa almışsınız. 9. mesajda verdiğim kodlarda sadece buna ve CL'ye kadar aktarmaya yönelik değişiklik yaptım. Makronun özünde bir değişiklik yapmadım.

Aşağıdaki kodları önce buraya yüklediğiniz son dosyada deneyin. Deneyince göreceksiniz ki sadece ikinci satırı aktaracak, üçüncü satırı aktarmasını istediğiniz halde aktarmayacak. Şaşırmayın, kod aslında doğru yapıyor çünkü rapor sayfanızda 3. satırda ALINDI değil ALNDI yazıyor, dolayısıyla da o satır aktarılmıyor.

Kod: 
Sub mükerreraktar()
Set s1 = Sheets("VERİ ")
Set s2 = Sheets("RAPOR")

son = s1.Cells(Rows.Count, "A").End(3).Row

For i = 1 To son
    aranan = s1.Cells(i, "A").Value
    If s1.Cells(i, "[COLOR="Red"]AL[/COLOR]") = "ALINDI" Or s1.Cells(i, "[COLOR="red"]AL[/COLOR]") = "ALINACAK" Then
        If WorksheetFunction.CountIfs(s1.Range("A1:A" & son), aranan, s1.Range("AL1:[COLOR="red"]AL[/COLOR]" & son), "BEKLİYOR") = 0 Then
            yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s1.Range("A" & i & ":[COLOR="red"]CL[/COLOR]" & i).Copy s2.Cells(yeni, "A")
        End If
    End If
Next
                
End Sub

Sonra isterseniz o satırdaki durumu ALINDI yapıp deneyin, isterseniz ekteki dosyayı inceleyin:

https://drive.google.com/file/d/1lTKwW918w8sQ4xE0ji-HL0BFCXiHgY2j/view?usp=sharing
 
Alternatif kod:

Kod: 
Sub Gruplandir()

ZBasla = TimeValue(Now)
zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlManual


Set s1 = Sheets("VERİ ") ' veri sayfası
Set s2 = Sheets("RAPOR") 'aktarılan sayfa

son1 = s1.Cells(Rows.Count, "a").End(3).Row

ReDim ara1(son1): ReDim ara2(son1): ReDim ara3(son1):

For j = 2 To son1
ara1(j) = WorksheetFunction.Trim(Cells(j, "AL"))
ara2(j) = 1
ara3(j) = WorksheetFunction.Trim(Cells(j, "a"))
Next j

sat1 = 2

For r = 2 To son1
aranan1 = ara1(r)
aranan3 = ara3(r)
If aranan1 = "BEKLİYOR" Then
If ara2(r) = 1 Then
For i = 2 To son1
If ara3(i) = aranan3 Then
ara2(i) = 0
End If
Next i
End If
End If
Next r

sat1 = 2
For r = 2 To son1
If ara2(r) = 1 Then
s1.Range(Cells(r, "A"), s1.Cells(r, "CL")).Copy
s2.Cells(sat1, "a").PasteSpecial Paste:=3

sat1 = sat1 + 1
End If
Next r

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
zBitis = TimeValue(Now)

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
"İşlem süresi ; " & Format(Timer - zaman, "0.00") & Chr(10) & _
"Geçen Süre " & CDate(zBitis - ZBasla), vbInformation, " Sonuç Penceresi"

End Sub
 
Merhaba sayın yusuf44 çok teşekkür ederim size kodalrınız tam istediğim gibi aktarıyor,Allah razı olsun bu kodları arşivime ekliyorum sorun çözüldü küçük bir isteğim daha olacak sizden
If WorksheetFunction.CountIfs(s1.Range("A1:A" & son), aranan, s1.Range("AL1:AL" & son), "BEKLİYOR") = 0 Then bu satırlara 2 inci bir seçenek eklesem yani "BEKLİYOR" ve "ALINDI" secenegi nasıl eklerim teşekkür ederim..
 
Aşağıdaki gibi deneyin:
Kod: 
Sub mükerreraktar()
Set s1 = Sheets("VERİ ")
Set s2 = Sheets("RAPOR")

son = s1.Cells(Rows.Count, "A").End(3).Row

For i = 1 To son
    aranan = s1.Cells(i, "A").Value
    If s1.Cells(i, "AL") = "ALINDI" Or s1.Cells(i, "AL") = "ALINACAK" Then
        If WorksheetFunction.CountIfs(s1.Range("A1:A" & son), aranan, s1.Range("AL1:AL" & son), "BEKLİYOR") = 0 [COLOR="Red"]And _
           WorksheetFunction.CountIfs(s1.Range("A1:A" & son), aranan, s1.Range("AL1:AL" & son), "ALINDI") = 0[/COLOR] Then
            yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
            s1.Range("A" & i & ":CL" & i).Copy s2.Cells(yeni, "A")
        End If
    End If
Next
                
End Sub
 
Malesef sayın yusuf44 = 0 dan sonra And_ ekleyince kod kırmızı oluyor ne yapmam gerek teşekkürler..
 
Bende sorun çıkmadı. Yeniden yazmak yerine kopyala yapıştır yapabilirsiniz.

O işaret uzun satırların takibini kolaylaştırmak için kodları alt satıra geçirmeden önce kullanılır (satır sonlarında kelime bölmek için kullanılan - gibi)

Muhtemelen And'dan sonra boşluk bırakmadan _ yaptınız. Verdiğim kodu incelerseniz And ile _ arasında bir boşluk var. Boşluk bırakmayınca hata verir.
 
Çok teşekkürler sayın yusuf44 bilgi için kodlar düzeldi fakat bu şekilde aktarım hiç olmuyor eklediğiniz satırı kaldırıp = 0 Then satırı olunca aktarım oluyor.
 
Siz dosyanızda nasıl bir uygulama yapıyorsunuz bilmiyorum ama ben kodları denedikten sonra buraya yazıyorum. Ve denememde istenen sonucu veriyor.

Son örnek dosyanız üzerinden gidersek eğer kodları son örnek dosyanızda yaptıysanız aktarım olmaması normaldir. Çünkü dosyada H ile başlayan ürün ALINDI ve ALINACAK; C ile başlayan ürün ise ALINDI, ALINACAK ve BEKLİYOR burumlarını içeriyor.

İlk durumdabir kodun en az bir BEKLİYOR durumu varsa aktarılmıyor, hiç bekliyor yoksa aktarılıyordu ve buna istinaden de verdiğim kod talebinize uygun olarak H ile başlayan ürün satırlarını aktarıyor, C ile başlayan satırları aktarmıyordu.

Kodun yeni durumunda BEKLİYOR ile birlikte ALINDI şartını da aramaya başkladık. Yani bir ürünün durumunda en az bir ALINDI ya da en az bir BEKLİYOR varsa aktarılmayacak, bunlar yoksa aktarılacak şeklinde ayarladık. Yani o kod için ALINDI ve BEKLİYOR durumunun 0 olmasını istedik.

Kodda ALINDI ilavesini yapınca H kodlu ürün de aktarılmamaya başladı çünkü o kodun da bir durumu ALINDI.

Sonuç olarak örnek dosyanızda aktarım olmaması normal çünkü biz öyle istiyoruz.

Örnek dosyanızda tek satırda durumu ALINACAK olan bir kod girerek sonucu gözlemleyin.

Örnek dosyanızda kodun uygulanmış hali ektedir:

https://drive.google.com/file/d/1itM7Iqd_RevExWcYbPWB-gInZm5MgwSz/view?usp=sharing
 
Sayın yusuf44 Allah razı olsun kendi dosyamdaki kriter hatasından dolayı kodu uygulayamadım kusura bakmayın,tabi ki burada gerçek dosya paylaşmak istemiyorum benim dosyamda "ALINACAK" ALINDI" BEKLİYOR" ingilizce kelimeler çift tırnak içindeki bir satırı düzeltip kendi dosyama uyarlayınca istenilen işlem oldu, aslında kodlarınız sorunsuz aktarım yapıyor sorun çözüldü,Çok teşekkür ederim kolay gelsin, hayırlı günler, tabiki diğer hocaların HALİT3 ve sayın Ziynettin sizede ayrıca teşekkür ederim..
 
Hiç kimseden gerçek dosya paylaşmasını istemiyor ve beklemiyoruz elbette. Önemli olan asıl dosyanızla aynı yapıda dosya olması. Ancak sizin durumdaki gibi zaman zaman soru sahipleri kodları ya da formülleri gerçek dosyaya uyarlayamadıkları için sorun oluyor böyle. Bunda yapabileceğimiz bir şey yok maalesef.

Bundan sonraki sorularınızda inşallah bu sorudaki gibi "anlaşamamazlık" olmaz :)

İyi çalışmalar.
 
Haklısınız yusuf44 bazen bizde yapmak istediğimiz şeyleri anlatmakta zorlanıyoruz,ama sayenizde hem işlerirmiz hızlanıp kolaylaşıyor,hem excel ve makrolarla çalışmayı öğreniyoruz teşekkürler iyi çalışmalar.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst