Çok Değişkenli Verileri Kriterlere Göre Aktarma

Ömer BARAN · 19 Ekim 2015

Merhaba.

Açıklamalar iyi gibi görünüyor, tek eksik; BARAN adlı sayfada solda benim eklediğim
AKTAR düğmesini kullanmadan, ÜRETİM VERİLERİ sayfasındaki veriler için
S15-3211, S15-3205 ve S15-3207 kodları için,
benim "sütun no" yazdığım 11'inci satırın üstüne yeni satırlar ekleyerek,
OLMASI GEREKEN sonuçları formül kullanmadan elle yazar mısınız?

Böylece; oluşturulacak kod'un doğru sonucu verdiğinin
(satır sayısı ve sonuç veriler bakımından) kontrolü sağlanmış olur.

Bundan sonra bir şeyler yapıp belgeyi siteye tekrar eklerim ve sorulacak yeni bir konu varsa onu sorarım.
.

Ömer BARAN · 19 Ekim 2015

Bir önceki cevabımı da okuyunuz.

Bir önceki cevabıma göre yükleyeceğiniz yeni belgede, BARAN adlı sayfada,
her bir satırın neden eklendiğini o satırda sağ tarafa (R sütunu gibi)
kısa açıklama cümlesi de yazarsanız daha iyi olur.

y.selim · 19 Ekim 2015

İstediklerinizi dosyaya ekledim.

Ömer BARAN · 20 Ekim 2015

y.selim' Alıntı:
İstediklerinizi dosyaya ekledim.

Tekrar merhaba.

Hesaplamaların doğruluğu bakımından ekli belgeyi test eder misiniz?
Listeleme ve sayı toplama olayına hiç bakmadım, sadece melzeme/ürün kodlarını kontrol ediniz.

Belge içerisindeki uyarılara dikkat ediniz.

Eksik/hata varsa belgede değişiklik yapmak yerine açıklamalar için
METİN KUTUSU kullanıp kaydettikten sonra tekrar siteye yüklersiniz.

y.selim · 20 Ekim 2015

Merhaba Sayın Baran
Dosyayı inceledim genel itibariyle iyi görünüyor.Düzeltilecek bir kaç ayrıntıyı dosya da belirttim.İyi çalışmalar.

Ömer BARAN · 20 Ekim 2015

Tekrar merhaba.
Herbir SİPARİŞ NO için oluşacak satır sayısı;
.. AP-AQ-AR sütunlarındaki DOLU SATIR sayısı (bu sütunları tek bir hücre gibi düşünün)
.. + AS-AV sütunlarındaki DOLU HÜCRE sayısı
şeklinde olacak, bu gözle değerlendirir misiniz?
Daha evvel de yazdığım gibi önemli olan SATIR sayısının tespit edilmesi, bu konuda yukarıdaki açıklamama göre bir bakar mısınız?

y.selim · 20 Ekim 2015

Merhaba

Satır sayısını belirleyen AS-AT-AU-AV sütunlarıdır.Ne kadar dolu hücre varsa o kadar satır olacak.Mesela;

birinci siparişte 4 dolu hücre olduğundan 4 satır
ikinci siparişte 6 dolu hücre olduğundan 6 satır
üçüncü siparişte 11 dolu hücre olduğundan 11 satır olacak

AP-AQ-AR sütunları yukarıdaki sütunlardaki şartlara göre otomatik olarak dolacak, satır sayısını etkilemiyor.

Ömer BARAN · 23 Ekim 2015

Merhaba.
Ekteki belgeyi inceleyip, konu sayfasında geri bildirimde bulunursunuz.

y.selim · 23 Ekim 2015

Merhaba
15.000 veri de yaklaşık 50 saniye sürüyor. (Uzun sürmesi çok problem değil)
Fakat 61.satırdan sonra işlem yapmıyor ve 400 hata kodunu veriyor.
Ekte ki dosyaya denemeniz için 900 satırlık veri ekledim.
Saygılarımla iyi çalışmalar

Ömer BARAN · 23 Ekim 2015

61'inci satırda listelerde olmayan bir veri var, T - E (Q ve R sütununda) şeklinde.
Sayfa2'ye ait kod sayfasındaki kod'u aşağıdaki ile değiştirip süreyi de görebilirsiniz.
Bendeki deneme, mevcut verilerle 2-3 saniyede tamamlanıyor.
Tabi süre bilgisayarınızın konfigürasyonuna bağlı olarak değişir.

Kod:

Sub SATIRTESPİTYARISITAMAM()
Dim UV As Worksheet: Set UV = Sheets("Sayfa2")
Dim T As Worksheet: Set T = Sheets("TABLO")

UV.Range("BA:BD").ClearContents
UV.Range("AP:AV").ClearContents
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

UV.Range("AP1") = "TÜR": UV.Range("AQ1") = "GRUP": UV.Range("AR1") = "RENK": UV.Range("AS1") = "KAPI KOD"
UV.Range("AT1") = "KİLİT KOD": UV.Range("AU1") = "MENTEŞE KOD": UV.Range("AV1") = "KOL KOD"
UV.Cells(1, 53) = "KA": UV.Cells(1, 54) = "Kİ": UV.Cells(1, 55) = "ME": UV.Cells(1, 56) = "KO"
süre = Timer
On Error Resume Next
'******SATIR TESPİT*******
For sat = 2 To UV.[G65536].End(3).Row
UV.Cells(sat, 57) = UV.Cells(sat, 7) & " | " & UV.Cells(sat, 16) & " | " & UV.Cells(sat, 18) _
                    & " | " & UV.Cells(sat, 19) & " | " & UV.Cells(sat, 20)
        If WorksheetFunction.CountIf(Range("BE1:BE" & sat), UV.Cells(sat, 57)) = 1 Then
            UV.Cells(sat, 53) = 1
        Else
            UV.Cells(sat, 53) = 0
        End If
Next

'******SATIR TESPİT    BA:BD-> 1-0 *******
For sat = 2 To UV.[G65536].End(3).Row
UV.Cells(sat, 57) = UV.Cells(sat, 7) & " | " & UV.Cells(sat, 34)
        If WorksheetFunction.CountIf(Range("BE1:BE" & sat), UV.Cells(sat, 57)) = 1 Then
            UV.Cells(sat, 54) = 1
        Else
            UV.Cells(sat, 54) = 0
        End If
'v=WorksheetFunction.SumIf
Next
For sat = 2 To UV.[G65536].End(3).Row
UV.Cells(sat, 57) = UV.Cells(sat, 7) & " | " & UV.Cells(sat, 10)
        If WorksheetFunction.CountIf(Range("BE1:BE" & sat), UV.Cells(sat, 57)) = 1 Then
            UV.Cells(sat, 55) = 1
        Else
            UV.Cells(sat, 55) = 0
        End If
Next
For sat = 2 To UV.[G65536].End(3).Row
UV.Cells(sat, 57) = UV.Cells(sat, 7) & " | " & UV.Cells(sat, 38)
        If WorksheetFunction.CountIf(Range("BE1:BE" & sat), UV.Cells(sat, 57)) = 1 Then
            UV.Cells(sat, 56) = 1
        Else
            UV.Cells(sat, 56) = 0
        End If
Next
UV.Range("BE:BE").ClearContents
UV.Cells(1, 57) = "57"

'******* TÜR / GRUP / RENK ******
For sat = 2 To UV.[G65536].End(3).Row
    qq = UV.[AP65536].End(3).Row + 1
    zz = WorksheetFunction.Match(Cells(sat, 7), UV.Range("G:G"), 0)

        If zz > qq Then
            a = zz
        Else
            a = qq
        End If
            If Cells(sat, 53) = 0 Then GoTo 10
                    UV.Cells(a, 42) = T.Cells(WorksheetFunction.Match(Cells(sat, 20), T.Range("j2:j11"), 0) + 1, 11)
                If WorksheetFunction.CountIf(T.Range("M2:M16"), UV.Cells(sat, 16)) = 0 Then
                    UV.Cells(a, 43) = "KAP.LAKE"
                    UV.Cells(a, 44) = UV.Cells(sat, 16)
                Else
                    UV.Cells(a, 43) = T.Cells(WorksheetFunction.Match(UV.Cells(sat, 16), T.Range("M2:M16"), 0) + 1, 13)
                    UV.Cells(a, 44) = UV.Cells(sat, 16)
                End If

'******* KAPI KODLARI ******
'******* KAPIKOD 2 ******
If WorksheetFunction.CountIf(T.Range("Z2:Z83"), "" & UV.Cells(sat, 19)) = 0 Then
    kod2 = ""
ElseIf UV.Cells(sat, 20) = "KASA" Then
    kod2 = T.Cells(WorksheetFunction.Match("" & UV.Cells(sat, 19), T.Range("Z2:Z83"), 0) + 1, 27)
ElseIf UV.Cells(sat, 20) = "KANAT" Then
    kod2 = "K " & T.Cells(WorksheetFunction.Match("" & UV.Cells(sat, 20), T.Range("w2:w5"), 0) + 1, 24)
Else
    kod2 = " " & T.Cells(WorksheetFunction.Match("" & UV.Cells(sat, 19), T.Range("Z2:Z83"), 0) + 1, 27)
End If
'******* KAPIKOD 3 ******
If UV.Cells(sat, 20) = "KASA" Or UV.Cells(sat, 20) = "TEK" Or UV.Cells(sat, 20) = "SÜRME" Then
    kod3 = ""
ElseIf WorksheetFunction.CountIf(T.Range("W2:W5"), UV.Cells(sat, 20)) > 0 Then
    kod3 = " " & T.Cells(WorksheetFunction.Match(UV.Cells(sat, 20), T.Range("W2:W5"), 0) + 1, 24)
Else
    kod3 = T.Cells(WorksheetFunction.Match(UV.Cells(sat, 20), T.Range("W2:W5"), 0) + 1, 24) 'hata31
End If

'******* KAPIKOD KONTROL KOD 1 ******
If UV.Cells(sat, 20) = "KASA" Then 'If UV.Cells(sat, 18) = "" Or UV.Cells(sat, 20) = "KASA" Then
    kod1 = ""
    kod2 = "KASA"
    kod3 = ""
ElseIf UV.Cells(sat, 20) = "KANAT" Then
    kod1 = "K "
    kod2 = T.Cells(WorksheetFunction.Match(UV.Cells(sat, 19) & "", T.Range("Z2:Z83"), 0) + 1, 27)
    kod3 = ""
End If

If UV.Cells(sat, 20) <> "KASA" And UV.Cells(sat, 20) <> "KANAT" Then
    kod1 = T.Cells(WorksheetFunction.Match(UV.Cells(sat, 18), T.Range("Q2:Q17"), 0) + 1, 18)
End If
UV.Cells(a, 45) = kod1 & kod2 & kod3
10: Next

'******KİLİT - MENTEŞE - KOL **** KENDİ SATIRINDA*******
For satAT = 2 To UV.[G65536].End(3).Row
    If UV.Cells(satAT, 54) = 1 Then
        kilitkod = T.Cells(WorksheetFunction.Match(UV.Cells(satAT, 34), T.Range("AC2:AC6"), 0) + 1, 30)
    Else
        kilitkod = ""
    End If
        If UV.Cells(satAT, 55) = 1 Then
            menteşekod = T.Cells(WorksheetFunction.Match(UV.Cells(satAT, 36), T.Range("AF2:AF4"), 0) + 1, 33)
        Else
            menteşekod = ""
        End If
            If UV.Cells(satAT, 56) = 1 Then
                kolkod = T.Cells(WorksheetFunction.Match(UV.Cells(satAT, 38), T.Range("AI2:AI22"), 0) + 1, 36)
            Else
                kolkod = ""
            End If
UV.Cells(satAT, 46) = kilitkod
UV.Cells(satAT, 47) = menteşekod
UV.Cells(satAT, 48) = kolkod
20: Next
'cc = Worksheet
'a= WorksheetFunction.CountA(
satırsayısı = 5

UV.Range("BA:BE").ClearContents
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - süre, "0.000"), vbInformation
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Ömer BARAN · 23 Ekim 2015

Tekrar merhaba.
S15-41 kod için 55 satırlık veri var ama bulunan kod adeti 4.
Acaba farklılık ölçmede dikkate alınacak başka sütun da mı var?
Bana garip geldi doğrusu.

y.selim · 23 Ekim 2015

55 satırlık veri de iki veri bulması gayet normal hocam hatta sadece bir tane de olabilir di.Bir binanın bütün daireleri aynı modelden yapılmış demektir.

Bu dosyada süre, bende de 2-3 saniye sürüyor.Veri satırını 15.000 civarına çıkarınca süre uzuyor.Ama çok önemli değil.

Evet 61.satırda veri tabanımızda olmayan bir varmış.O zaman kodlar hata bulduğu satırda duruyor.Peki böyle tanımsız veriler bulduğu zaman onları atlayıp diğer satırlara geçemez mi?Bu tür tanımsız veriler zaman zaman çıkabilir .

Bir de dosya içine eklenen açıklamalar vardı?Ve 400 hata kodunu vermeye devam ediyor.

Ömer BARAN · 23 Ekim 2015

Sondan ikinci cevabımdaki kodu uygularsanız hata almazsınız.

Ömer BARAN · 26 Ekim 2015

Tekrar merhaba.
Ekli belgeyi inceleyiniz.
Doğruluk ve süre ile ilgili olarak, konu sayfasına geri bildirimde bulunursunuz.

y.selim · 26 Ekim 2015

Sayın Baran dosyayı inceledim harika görünüyor.Emeğinize sağlık.14.000 satırlık işlemde 1dk da sonuç veriyor iyi bir süre.

Sanırım bir tek toplam aldırma işi kalmış.Bir de dosya ile ilgili birkaç küçük ricam olacak.

*Renkleri P den değil O sütunundan almalı.

*Renk adı B.LAKE ise renge BEYAZ/ BEJ LAKE ise renge BEJ yazsın

*Yeni model,renk ya da kod eklemek istersek bunu nasıl yapacağız?Veri tabanına yeni eklemeler yaparak deneme yaptım ama bunları görmüyor.

*Bir de işlem yaptıktan sonra yazan boylarla ilgili özel üretim bilgisini msgbox olarak vermesin. Bunu (mümkünse ve sizi çok uğraştırmayacaksa) her bir sipariş için ayrı ayrı siparişin en sağına bir boşluk bıraktıktan sonra kaç adet olduğunu yazsın.

Teşekkürler iyi çalışmalar.

Ömer BARAN · 26 Ekim 2015

Belgede Modül1'deki mevcut kod'u tamamen silip aşağıdakini yapıştırın.

-- Yeni kod ekleme işi için alt taraftan herhangi bir sayfa adına fareyle sağ tıklayın ve GÖSTER'i seçin
açılan küçük pencereden T'yi seçerek T adlı kod listesi sayfasına ulaşabilirsiniz.

T adlı sayfaya ekleme yaparak denediğimde ben sorun göremedim, "bu konuda eksiklik var, eklediğimi
görmüyor" diyorsanız o haliyle belgeyi kaydederek siteye ekleyin bakayım.

-- Adet-sayma işlemini anlamış değilim, bu nedenle; onu sona bırakıp listeleme olayı için TAMAM diyene kadar
(umarım listeleme için sonradan ilave bir şey olmaz) listeleme ile uğraşayım, adet-sayma işlerine sonra bakalım.

-- Açıklama: T adlı sayfada SARI zeminli başlığı olan sütunlar üretim verilerinin ilgili sütunlarındaki veriler,
SİYAH zeminli başlığı olanlar ise bunlara karşılık olarak listeleme sayfasında kod'un getireceği veriler oluyor
(tabi MAVİ zeminli olanları da kod, listeleme sayfasına getiriyor).

Kod:

Sub BARANLİSTE()
Dim U As Worksheet: Set U = Sheets("UV")
Dim T As Worksheet: Set T = Sheets("T")
Dim S As Worksheet: Set S = Sheets("S")
Dim G As Worksheet: Set G = Sheets("GİRİŞ")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

aalan = "A1:A" & T.[A65536].End(3).Row
dalan = "D1:D" & T.[E65536].End(3).Row
galan = "G1:G" & T.[H65536].End(3).Row
malan = "M1:M" & T.[M65536].End(3).Row
palan = "P1:P" & T.[P65536].End(3).Row
salan = "S1:S" & T.[S65536].End(3).Row
valan = "V1:V" & T.[V65536].End(3).Row
yalan = "Y1:Y" & T.[Y65536].End(3).Row
abalan = "AB1:AB" & T.[AB65536].End(3).Row

süre = Timer

Call TEMİZLE
    S.Columns("C:L").FormatConditions.Delete

For sip = 2 To G.[A65536].End(3).Row
    For sütun = 53 To 56
        For sat = G.Cells(sip, 2) To G.Cells(sip, 3)
                If sütun = 53 Then
                    U.Cells(sat, 57) = U.Cells(sat, 7) & " | " & U.Cells(sat, 16) & " | " & _
                    U.Cells(sat, 18) & " | " & U.Cells(sat, 19) & " | " & U.Cells(sat, 20)
                    ElseIf sütun = 54 Then
                        U.Cells(sat, 57) = U.Cells(sat, 7) & " | " & U.Cells(sat, 34)
                        ElseIf sütun = 55 Then
                            U.Cells(sat, 57) = U.Cells(sat, 7) & " | " & U.Cells(sat, 36)
                            Else
                                U.Cells(sat, 57) = U.Cells(sat, 7) & " | " & U.Cells(sat, 38)
                                End If
If WorksheetFunction.CountIf(Range("BE1:BE" & sat), U.Cells(sat, 57)) = 1 Then 'sütun = 53 And
    U.Cells(sat, sütun) = 1
    Else
        U.Cells(sat, sütun) = 0
        GoTo 20
        End If

On Error Resume Next
If U.Cells(sat, sütun) = 0 Then GoTo 100

If sütun = 53 And U.Cells(sat, 53) = 1 Then
If U.Cells(sat, 20) = "KASA" Then
    kod1 = "KASA"
    kod2 = ""
    kod3 = ""
ElseIf U.Cells(sat, 20) = "KANAT" Then
    kod1 = "K "
    kod2 = T.Cells(WorksheetFunction.Match(U.Cells(sat, 19) & "", T.Range(palan), 0), 17)
    kod3 = ""
ElseIf U.Cells(sat, 20) <> "KASA" And U.Cells(sat, 20) <> "KANAT" Then
    kod1 = T.Cells(WorksheetFunction.Match(U.Cells(sat, 18), T.Range(malan), 0), 14)
    kod2 = " " & T.Cells(WorksheetFunction.Match("" & U.Cells(sat, 19), T.Range(palan), 0), 17)
    kod3 = " " & T.Cells(WorksheetFunction.Match(U.Cells(sat, 20), T.Range(salan), 0), 20)
End If

S.Cells(S.[K65536].End(3).Row + 1, 11) = Trim(kod1 & kod2 & kod3)
    S.Cells(S.[K65536].End(3).Row, 3) = U.Cells(sat, 8)
    S.Cells(S.[K65536].End(3).Row, 4) = U.Cells(sat, 9)
    S.Cells(S.[K65536].End(3).Row, 5) = U.Cells(sat, 7)

S.Cells(S.[K65536].End(3).Row, 7) = T.Cells(WorksheetFunction.Match(Cells(sat, 20), T.Range(aalan), 0), 2)
        If WorksheetFunction.CountIf(T.Range(dalan), U.Cells(sat, 15)) = 0 Then
            S.Cells(S.[K65536].End(3).Row, 8) = "KAP.LAKE"
            S.Cells(S.[K65536].End(3).Row, 9) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 15), T.Range(galan), 0), 8)
            Else
                S.Cells(S.[K65536].End(3).Row, 8) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 15), T.Range(dalan), 0), 5)
                S.Cells(S.[K65536].End(3).Row, 9) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 15), T.Range(galan), 0), 8)
                End If
    
    ElseIf sütun = 54 And U.Cells(sat, 54) = 1 Then
        If U.Cells(sat, 34) = "HARİÇ" Or U.Cells(sat, 34) = "" Then GoTo 10
        
        S.Cells(S.[K65536].End(3).Row + 1, 11) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 34), T.Range(valan), 0), 23)
        S.Cells(S.[K65536].End(3).Row, 3) = U.Cells(sat, 8)
        S.Cells(S.[K65536].End(3).Row, 4) = U.Cells(sat, 9)
        S.Cells(S.[K65536].End(3).Row, 5) = U.Cells(sat, 7)
        S.Cells(S.[K65536].End(3).Row, 7) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 34), T.Range(valan), 0), 24)
        S.Cells(S.[K65536].End(3).Row, 8) = ""
        S.Cells(S.[K65536].End(3).Row, 9) = ""
10
        ElseIf sütun = 55 And U.Cells(sat, 55) = 1 Then
        If U.Cells(sat, 36) = "HARİÇ" Or U.Cells(sat, 36) = "" Then GoTo 20
        
            S.Cells(S.[K65536].End(3).Row + 1, 11) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 36), T.Range(yalan), 0), 26)
            S.Cells(S.[K65536].End(3).Row, 3) = U.Cells(sat, 8)
            S.Cells(S.[K65536].End(3).Row, 4) = U.Cells(sat, 9)
            S.Cells(S.[K65536].End(3).Row, 5) = U.Cells(sat, 7)
            S.Cells(S.[K65536].End(3).Row, 7) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 36), T.Range(yalan), 0), 27)
            S.Cells(S.[K65536].End(3).Row, 8) = ""
            S.Cells(S.[K65536].End(3).Row, 9) = ""
20
            ElseIf sütun = 56 And U.Cells(sat, 56) = 1 Then
        If U.Cells(sat, 38) = "HARİÇ" Or U.Cells(sat, 38) = "" Then GoTo 20
        
                S.Cells(S.[K65536].End(3).Row + 1, 11) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 38), T.Range(abalan), 0), 29)
                S.Cells(S.[K65536].End(3).Row, 3) = U.Cells(sat, 8)
                S.Cells(S.[K65536].End(3).Row, 4) = U.Cells(sat, 9)
                S.Cells(S.[K65536].End(3).Row, 5) = U.Cells(sat, 7)
                S.Cells(S.[K65536].End(3).Row, 7) = T.Cells(WorksheetFunction.Match(U.Cells(sat, 38), T.Range(abalan), 0), 30)
                S.Cells(S.[K65536].End(3).Row, 8) = ""
                S.Cells(S.[K65536].End(3).Row, 9) = ""
30
                End If
100
Next
Next
Next
S.Range("C1:L1").AutoFilter Field:=9
U.Range("BA:BE").ClearContents

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
S.Activate
S.Columns("C:L").EntireColumn.AutoFit
S.Columns("F").ColumnWidth = 2.14
S.Columns("J").ColumnWidth = 2.14
biçimalan = "C2:E" & S.[K65536].End(3).Row
    Cells.FormatConditions.Delete
    S.Range(biçimalan).FormatConditions.Add Type:=xlExpression, Formula1:="=$C2<>$C1"
    S.Range(biçimalan).FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With S.Range(biçimalan).FormatConditions(1)
        .Interior.ColorIndex = 15
        .Font.Bold = True
    End With
ab210 = WorksheetFunction.CountIf(U.Range("AB:AB"), ">210")
ad275 = WorksheetFunction.CountIf(U.Range("AD:AD"), ">27.5")

S.Cells(S.[A65536].End(3).Row + 1, 1) = Format(Timer - süre, "0.00")
MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
       "Kapı Boyu 210,00 cm'den büyük olan   " & ab210 & "   adet satır var." & Chr(10) & _
       "Kasa Eni      27,50 cm'den büyük olan   " & ad275 & "   adet satır var." & Chr(10) & _
       "İşlem süresi ; " & Format(Timer - süre, "0.00"), vbInformation
End Sub

Sub TEMİZLE()
Dim U As Worksheet: Set U = Sheets("UV")
Dim T As Worksheet: Set T = Sheets("T")
Dim S As Worksheet: Set S = Sheets("S")
Dim G As Worksheet: Set G = Sheets("GİRİŞ")

U.Range("BA:BE").ClearContents
S.Range("C:L").ClearContents
S.Range("C1") = "BAYİ": S.Range("D1") = "MÜŞTERİ": S.Range("E1") = "NUMARA": S.Range("G1") = "TÜR"
S.Range("H1") = "GRUP": S.Range("I1") = "RENK": S.Range("K1") = "ÜRÜN KODU": S.Range("L1") = "ÜRÜN ADET"

Call KODLİSTESİ
U.Activate
End Sub

Sub KODLİSTESİ()
Dim U As Worksheet: Set U = Sheets("UV")
Dim G As Worksheet: Set G = Sheets("GİRİŞ")

G.Range("A:C").ClearContents
G.Cells(1, 1) = U.Cells(1, 7)
U.Range("G1:G" & U.[G65536].End(3).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=G.Range("A1"), Unique:=True
G.Cells(1, 2) = "BAŞ": G.Cells(1, 3) = "BİT"

With G.Range("B2:B" & G.[A65536].End(3).Row)
    .Formula = "=MATCH($A2,UV!$G:$G,0)"
    .Value = .Value
End With

With G.Range("C2:C" & G.[A65536].End(3).Row)
    .Formula = "=MATCH($A2,UV!$G:$G,0)+COUNTIF(UV!$G:$G,$A2)-1"
    .Value = .Value
End With
With G.Range("A2:C" & G.[A65536].End(3).Row + 10)
    .Interior.Color = xlNone
End With
End Sub

y.selim · 27 Ekim 2015

Her şey tamam hocam, sadece özel üretim ihtiva eden boylarla ilgili yazmış olduğum mesele kaldı bununla ilgili ne dersiniz?

((Bir de işlem yaptıktan sonra yazan boylarla ilgili özel üretim bilgisini msgbox olarak vermesin. Bunu (mümkünse ve sizi çok uğraştırmayacaksa) her bir sipariş için ayrı ayrı siparişin en sağına bir boşluk bıraktıktan sonra kaç adet olduğunu yazsın))

Ömer BARAN · 27 Ekim 2015

Tekrar merhaba.

Ekli belgeyi inceleyiniz.

y.selim · 28 Ekim 2015

Dosya da anlatmaya çalıştım Sayın Baran

Ömer BARAN · 28 Ekim 2015

Ekteki dosyayı test ediniz.

Bu cevap ekindeki belgeyi kaldırdım,
bir sonraki cevap ekindeki belgeye bakınız.

Çok Değişkenli Verileri Kriterlere Göre Aktarma

Uzman

Uzman

Ekli dosyalar

Uzman

Ekli dosyalar

Ekli dosyalar

Uzman

Uzman

Ekli dosyalar

Ekli dosyalar

Uzman

Uzman

Uzman

Uzman

Ekli dosyalar

Uzman

Uzman

Ekli dosyalar

Ekli dosyalar

Uzman