• DİKKAT

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

Düşeyara yada kodla yardım

  • Konbuyu başlatan Konbuyu başlatan engin52
  • Başlangıç tarihi Başlangıç tarihi
E

engin52

Katılım
24 Temmuz 2008
Mesajlar
172
Excel Vers. ve Dili
2010 türkçe
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
 
Son düzenleme:
Ö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.
 
Merhaba,

Dosyanızı DOSYA.TC ekleyiniz.
 
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.
Kod: 
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
 
vardar07' Alıntı:
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.
Kod: 
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
Genişletmek için tıkla ...

evet birim fiyatlar değişken.
şu şekilde bir hata verdi.
Run-Time Error '13':
Type mismatch
 
Ekteki dosyayı inceleyin eksik yada fazla tarafına göre düzenlensin. Birim fiyatını farklı olduğu için uyarlamadım.
 

Ekli dosyalar

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...
 
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.
 
Evet F yerine N yazabilirsiniz. Kolay gelsin.
 
İ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?
 
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.
 
Deneyiniz.
Kod: 
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
 
Son düzenleme:
Rica ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst