Yekün toplam almak.

[Galus]

Ekte sunulan çalışmaya ÜRÜN ve Hammaddelerin kodlarına göre yekün toplamlarını RAPOR butonuna basınca almak münkün mü?

Teşekkürler..

 

[tahsinanarat]

Neden uretim adlı dosyanızın formul sayfasındaki gibi alt alta yazmıyor, ve oradaki miktarların yanındaki (p,pp,ppp,d'leri) başlık kısmında kullanmıyorsunuz, gerçi dosyanızın içeriğini tam olarak tahmin etmek zor, ama görünüşte dediğim gibi kullanmış olursanız, toplam almak ta, istediğin gibi rapor almakta daha kolay olacaktır diye düşünüyorum.

 

[Ferhat Pazarçevirdi]

Ekteki dosyayı inceleyiniz.

 

[tahsinanarat]

Artık öyle düşünmüyorum, elinize sağlık sayın fpc

 

[Galus]

Sayın fpc,

Sonsuz teşekkürler.. Rapor bilgilerini yeni bir sayfaya aktarabirsem bu iş tamam.

Saygılar...

 

[Necdet]

yekun=toplam

 

[Galus]

Neden uretim adlı dosyanızın formul sayfasındaki gibi alt alta yazmıyor, ve oradaki miktarların yanındaki (p,pp,ppp,d'leri) başlık kısmında kullanmıyorsunuz, gerçi dosyanızın içeriğini tam olarak tahmin etmek zor, ama görünüşte dediğim gibi kullanmış olursanız, toplam almak ta, istediğin gibi rapor almakta daha kolay olacaktır diye düşünüyorum.

Sayın tahsinanarat,

Mükemmel değil ama anlayıp kullanabileceğim bir şeyleri değerli yardımlarınızla yapmaya çalışıyorum. Değerli desteklerine minnettarım.

 

[Galus]

Sayın fpc,

Rapor bilgilerini yeni bir sayfaya aktarabilmeyi başaramadım. Lütfen yardım. Butono basınca toplamlar Sayfa2 ye getirmeniz münkün mü?

Teşekkürler..

 

[Ferhat Pazarçevirdi]

Size gönderdiğim dosyadaki kodu silip aşağıdakini yapıştırın.

Sub raporla()
Set sh = Sheets("Rapor")
sonu = sh.Cells(65536, 4).End(xlUp).Row
Set sh2 = Sheets("Sayfa2")
sh2.Columns("A:D").ClearContents
sh2.Cells(1, 1) = "Ürün Cinsi"
sh2.Cells(1, 2) = "Miktar"
sh2.Cells(1, 3) = "Hammadde Cinsi"
sh2.Cells(1, 4) = "Miktarı"
   For i = 1 To sonu
       Set rg = sh.Range("D1:D" & i)
       If sh.Cells(i, 4) = "" Then GoTo f1
            x = Application.WorksheetFunction.CountIf(rg, sh.Cells(i, 4))
            If x = 1 Then
                sonr = sh2.Cells(65536, 1).End(xlUp).Row
                sh2.Cells(sonr + 1, 1) = sh.Cells(i, 4)
                sh2.Cells(sonr + 1, 2) = Application.WorksheetFunction.SumIf(sh.Range("D:D"), sh2.Cells(sonr + 1, 1), sh.Range("E:E"))
            End If
       Set rg = Nothing
f1:
   Next i
sonh = sh.Cells(65536, 6).End(xlUp).Row
   For i = 1 To sonh
       Set rg = sh.Range("F1:F" & i)
       If sh.Cells(i, 6) = "Hammadde:" Or sh.Cells(i, 6) = "" Or sh.Cells(i, 6) = 0 Then GoTo f2
            x = Application.WorksheetFunction.CountIf(rg, sh.Cells(i, 6))
            If x = 1 Then
                sonr = sh2.Cells(65536, 3).End(xlUp).Row
                sh2.Cells(sonr + 1, 3) = sh.Cells(i, 6)
                sh2.Cells(sonr + 1, 4) = Application.WorksheetFunction.SumIf(sh.Range("F:F"), sh2.Cells(sonr + 1, 3), sh.Range("G:G"))
            End If
       Set rg = Nothing
f2:
   Next i
   sh2.Select
   
Set sh = Nothing
Set sh2 = Nothing
End Sub

 

[Galus]

Sayın fpc,

Saygılar, teşekkürler....

 

[Galus]

Sayfada üretim tarihleri olsaydı, tarih aralığına göre rapor almamız münkün olur muydu?

Teşekkürler..

 

[Recep İpek]

Örnek dosyanızı buna göre tekrar ekleyebilirmisiniz.

 

[Galus]

Yukarıdaki Rapor1 dosyasına rapor sayfasına tarih sütunu eklenseydi demek istemiştim. Ben sutun ekleyince makro bozuluyor. Onun için işlemi ustalarıma bıraktım.

Saygılar..

 

[Recep İpek]

Hangi kolona tarih ekleyeceksiniz?

 

[Galus]

Rapor sayfasında lot numarsının yanına C sütununa. Yani ürün stünu C den D ye geçecek. Lot no ile Ürün arasına Tarih sütunu girecek.

Teşekkürler..

 

[Ferhat Pazarçevirdi]

Sütunu ekledikten sonra; aşağıdaki kodları kullanın.

Sub raporla()
Set sh = Sheets("Rapor")
sonu = sh.Cells(65536, 5).End(xlUp).Row
Set sh2 = Sheets("Sayfa2")
sh2.Columns("A:D").ClearContents
sh2.Cells(1, 1) = "Ürün Cinsi"
sh2.Cells(1, 2) = "Miktar"
sh2.Cells(1, 3) = "Hammadde Cinsi"
sh2.Cells(1, 4) = "Miktarı"
   For i = 1 To sonu
       Set rg = sh.Range("E1:E" & i)
       If sh.Cells(i, 5) = "" Then GoTo f1
            x = Application.WorksheetFunction.CountIf(rg, sh.Cells(i, 5))
            If x = 1 Then
                sonr = sh2.Cells(65536, 1).End(xlUp).Row
                sh2.Cells(sonr + 1, 1) = sh.Cells(i, 5)
                sh2.Cells(sonr + 1, 2) = Application.WorksheetFunction.SumIf(sh.Range("E:E"), sh2.Cells(sonr + 1, 1), sh.Range("F:F"))
            End If
       Set rg = Nothing
f1:
   Next i
sonh = sh.Cells(65536, 7).End(xlUp).Row
   For i = 1 To sonh
       Set rg = sh.Range("G1:G" & i)
       If sh.Cells(i, 7) = "Hammadde:" Or sh.Cells(i, 7) = "" Or sh.Cells(i, 7) = 0 Then GoTo f2
            x = Application.WorksheetFunction.CountIf(rg, sh.Cells(i, 7))
            If x = 1 Then
                sonr = sh2.Cells(65536, 3).End(xlUp).Row
                sh2.Cells(sonr + 1, 3) = sh.Cells(i, 7)
                sh2.Cells(sonr + 1, 4) = Application.WorksheetFunction.SumIf(sh.Range("G:G"), sh2.Cells(sonr + 1, 3), sh.Range("H:H"))
            End If
       Set rg = Nothing
f2:
   Next i
   sh2.Select
   
Set sh = Nothing
Set sh2 = Nothing
End Sub

 

[Recep İpek]

Aşağıdaki kodları kullanabilirsiniz.

Sub AktarTopla()
Dim a, c, i, j, n, k, b(), d()
Set s1 = Sheets("Rapor")
Set s2 = Sheets("Sayfa2")
'*******************************************
a = s1.Range("e1:f" & s1.[f65536].End(3).Row).Resize(, 2).Value
ReDim b(1 To UBound(a, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For i = 1 To UBound(a, 1)
            If Not IsEmpty(a(i, 1)) Then
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    b(n, 1) = n
                    b(n, 2) = a(i, 1)
                    .Add a(i, 1), n
                End If
                b(.Item(a(i, 1)), 3) = b(.Item(a(i, 1)), 3) + a(i, 2)
            End If
    Next
End With
s2.Range("a2:C5000").ClearContents
s2.[a2].Resize(n, 3).Value = b
'*******************************************
c = s1.Range("c1:h" & s1.[c65536].End(3).Row).Resize(, 6).Value
ReDim d(1 To UBound(c, 1), 1 To 3)
With CreateObject("Scripting.Dictionary")
    .CompareMode = vbTextCompare
    For j = 1 To UBound(c, 1)
            If Not IsEmpty(c(j, 5)) And c(j, 5) <> "Hammadde:" Then
                If CDate(c(j, 1)) >= CDate([K2]) And CDate(c(j, 1)) <= CDate([L2]) Then
                    If Not .exists(c(j, 5)) Then
                        k = k + 1
                        d(k, 1) = k
                        d(k, 2) = c(j, 5)
                        .Add c(j, 5), k
                    End If
                    d(.Item(c(j, 5)), 3) = d(.Item(c(j, 5)), 3) + c(j, 6)
                End If
            End If
     Next
End With
s2.Range("e2:g5000").ClearContents
s2.[e2].Resize(k, 3).Value = d
'*******************************************
MsgBox "Bitti"
s2.Select
[a1].Select
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Galus]

Sayın ripek,

Sonsuz teşekkürler... Emeğine sağlık, Allah razı olsun.

 

[Recep İpek]

Allah hepimizden razı olsun.

İşinize yaradığına sevindim.

 

[Galus]

"İnsanların en hayırlısı insanlara faydalı olandır!"
Sonuçta benim teşekkürümden öte Allah katında mutlaka ecriniz vardır. Cenabı Allah ecrinizi arttırsın.