Düşeyara yada kodla yardım

[engin52]

Merhabalar,
1. sayfada A sütununda bir ürün listesi var. Anı sayfanın B ve C sütunlarında miktar ve tutar var. B ve C sütunlarına 2. 3. 4. 5. sayfalardan 1. sayfanın A sütunudaki ürüne denk gelen miktar ve tutarları toplattırmak istiyorum. 2. 3. 4. 5. sayfalardaki ürünler 1. sayfadaki sırada değil ve aynı zamanda 2. sayfada olan ürün 3. sayfada olmaya bilir. Bununla ilgili bir kod yada formül önerir misiniz. Düşeyara formülü olmuyor.
Teşekkür ederim.

örnek dosya: https://upterabit.com/1KnI/ZAİMOĞLU.xls

 

[vardar07]

Örnek excel dosyanızı,açıklamalarını da yazarak; UPTERABİT.COM, DOSYA.TC, DOSYA.CO gibi dosya paylaşım sitelerine ekleyip linkini burada bildirirseniz yardım almanız daha kolay olur.

 

[engin52]

Örnek dosya linki linki aşagıda yardımcı olur musunuz.
Ekli dosyada 1 ve 2 adıyla açmış olduğum sayfalar olmadan çözmek istiyorum.
https://upterabit.com/1KnI/ZAİMOĞLU.xls

 

[engin52]

yardım edecek kimse yok mu?

 

[NBATMAN]

Merhaba,

Dosyanızı DOSYA.TC ekleyiniz.

 

[engin52]

Merhaba NBATMAN,
dosya linki: http://s3.dosya.tc/server10/8uad2y/ZAIMOGLU.xls.html

 

[vardar07]

Birim fiyatlar hep değişikmi? mesela şeker ocak ta 3 şubat ta 2. bunları düzeltip. aşağıdaki kodu stok tanım sayfasına ekleyip çalıştıp deneyin.

Sub aktar()
Range("B3:D" & Range("A65536").End(3).Row).ClearContents
a = Sheets.Count
Application.ScreenUpdating = False
For i = 1 To a
syf = Sheets(i).Name
If syf <> "STOK_TANIM" Then
If Not IsNumeric(syf) Then
For m = 3 To 11
With Sheets(syf).Range("c3:c500") 'Worksheets(1).Range("a1:a500")
    Set c = .Find(Cells(m, 1), LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
        Cells(m, 2) = Cells(m, 2) + Sheets(syf).Cells(c.Row, "E")
        Cells(m, 4) = Sheets(syf).Cells(c.Row, "F")
         Cells(m, 3) = Cells(m, 2) * Cells(m, 4)
            'c.Value = 5
            Set c = .FindNext(c)
            If c Is Nothing Then
                GoTo 10
            End If
            Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
10:
End With
Next m
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Bitti."
End Sub

 

[engin52]

Birim fiyatlar hep değişikmi? mesela şeker ocak ta 3 şubat ta 2. bunları düzeltip. aşağıdaki kodu stok tanım sayfasına ekleyip çalıştıp deneyin.

Sub aktar()
Range("B3:D" & Range("A65536").End(3).Row).ClearContents
a = Sheets.Count
Application.ScreenUpdating = False
For i = 1 To a
syf = Sheets(i).Name
If syf <> "STOK_TANIM" Then
If Not IsNumeric(syf) Then
For m = 3 To 11
With Sheets(syf).Range("c3:c500") 'Worksheets(1).Range("a1:a500")
    Set c = .Find(Cells(m, 1), LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        Do
        Cells(m, 2) = Cells(m, 2) + Sheets(syf).Cells(c.Row, "E")
        Cells(m, 4) = Sheets(syf).Cells(c.Row, "F")
         Cells(m, 3) = Cells(m, 2) * Cells(m, 4)
            'c.Value = 5
            Set c = .FindNext(c)
            If c Is Nothing Then
                GoTo 10
            End If
            Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
10:
End With
Next m
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "Aktarım Bitti."
End Sub

evet birim fiyatlar değişken.
şu şekilde bir hata verdi.
Run-Time Error '13':
Type mismatch

 

[vardar07]

Ekteki dosyayı inceleyin eksik yada fazla tarafına göre düzenlensin. Birim fiyatını farklı olduğu için uyarlamadım.

 

[engin52]

Sayın Vardar07 ne kadar teşekkür etsem azdır. formüllerle uğraşıyordum, beni kurtardınız. çok çok teşekkürler. Tutara F değil N sütunu olacaktı bedeğiştirdim ve hallettim.
Elinize sağlık...

 

[engin52]

Ayrıca birşey daha sorayım. kodda yazılı 'F' yerine 'N' yazmam yeterli değil mi? yani birim fiyatı değil toplam tutarı alacaktı. ve birim fiyatı ortalamasını aldıracam. aynı yerde ben onu yaparım formülle hallederim.

 

[vardar07]

Evet F yerine N yazabilirsiniz. Kolay gelsin.

 

[engin52]

Teşekkürler

Elinize sağlık

 

[engin52]

İyi akşamlar vardar07 bey...
Yaptığımız çalışmada ufak bir eksiklik var. boş değil de sıfır olan hücrelere rakam yazıyor. Bu konuda da yardımcı olabilir misiniz?

 

[engin52]

örnek dosyayı yükleyeyim isterseniz

 

[vardar07]

Dosyanın son halini eklerseniz iyi olur birde "boş değil de sıfır olan hücrelere rakam yazıyor." derken neyi kastettiğinizi dosya içinde renklendirin şurası şöyle burası böyle diye belirtin.

 

[engin52]

Dosyanın son halini açıklamaları ile birlikte yükledim. yardımcı olur musunuz?
link:http://s8.dosya.tc/server3/6degxd/zz_2016_DEVIR.xls.html

 

[vardar07]

Deneyiniz.

Sub aktar()
Set sh = Sheets("[COLOR="Red"]STOK_TANIM[/COLOR]")
ilk = Time
Application.ScreenUpdating = False
sh.Range("B3:E" & sh.Range("A1003").End(3).Row).ClearContents
For i = 1 To Sheets.Count
syf = Sheets(i).Name
If syf <> "[COLOR="red"]STOK_TANIM[/COLOR]" Then
If Not IsNumeric(syf) Then

For m = 3 To sh.Range("A1003").End(3).Row
With Sheets(syf).Range("c3:c" & Sheets(syf).Range("E1003").End(3).Row)
    Set c = .Find(sh.Cells(m, 1), LookIn:=xlValues)
    If Not c Is Nothing Then
        firstAddress = c.Address
        
        Do
        If sh.Cells(m, 1) = 0 Then
        sh.Cells(m, 2) = 0: sh.Cells(m, 3) = 0: sh.Cells(m, 5) = 0
        Else
        sh.Cells(m, 2) = sh.Cells(m, 2) + Sheets(syf).Cells(c.Row, "E")
        If sh.Cells(m, 2) < 1 Then sh.Cells(m, 2) = "": sh.Cells(m, 3) = ""
        sh.Cells(m, 3) = sh.Cells(m, 3) + Sheets(syf).Cells(c.Row, "N")
        End If
            Set c = .FindNext(c)
            If c Is Nothing Then
                GoTo 10
            End If
            Loop While Not c Is Nothing And c.Address <> firstAddress
    
    End If
10:
End With
Next
End If
End If
Next
Application.ScreenUpdating = True
son = Time
MsgBox Format(son - ilk, "h:mm:ss,000") & "  :saniyede  Aktarım Bitti.", vbInformation
End Sub

 

[engin52]

Çok Teşekkür ederim.
Ellerinize sağlık.

 

[vardar07]

Rica ederim.