Sayfadan veri bulup toplama

[TİKOS]

Sevgili arkadaşlar,
Ekteki sayfada açıkladığım işlem ile ilgili bana yardımcı olursanız çok sevinirim.
Büyük ihtimalle kodla çzömek gerekiyor. Ben başaramadım.
Yardımlarınızı rica ediyorum.
Teşekkürler

 

[Bagcivan]

tüm kalıpların toplamını mı istiyorsunuz?

Örneğin,

Gönderdiğiniz dosyanın özet sayfasının D8 hücresine aşağıdaki kodu yapıştırırsanız, sadece DENİZLİK ÇATI FENERİ PENCERE kalıbının toplamını verir.

=TOPLA.ÇARPIM((planlama!E7:Z7>=D5)*(planlama!E7:Z7<=D6)*(planlama!E32:Z32=D7)*(planlama!E37:Z37))

 

[TİKOS]

Öncelikle sorunum ile ilgilendiğiniz için teşekkürler.
Tüm sayfadaki yani E26:Z61 Hücreleri arasındaki OLUŞUM firmasının toplamını yani kırmızı ile yazılan
tutarların toplamını görmek istiyorum.

 

[TİKOS]

Arkadaşlar yardım lütfen

 

[TİKOS]

arkadaşlar bir al atın lütfenn

 

[chngrcn]

acele etmeyin, dosyanız üzerinde çalışıyorum..

 

[chngrcn]

Sub bul_topla()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim i As Long

Set s1 = Sheets("planlama")
Set s2 = Sheets("ozet")

sat1 = s1.Cells(65536, "E").End(xlUp).Row

Application.ScreenUpdating = False
For i = 7 To s1.Cells(5, s1.Columns.Count).End(xlToLeft).Column
    If s1.Cells(7, i).Value >= CDate(s2.Cells(5, 4).Value) And _
    s1.Cells(7, i).Value <= CDate(s2.Cells(6, 4).Value) Then
        For y = 26 To sat1
        If s1.Cells(y, i).Value = s2.Cells(7, 4).Value Then
            s2.Cells(8, 4).Value = s1.Cells(y + 5, i).Value
               End If
           Next y
        End If
    Next i
End Sub

buray kadar getirdim, üzerinde çalışıyorum halen..

 

[Husgvarna]

Merhaba.
Alternatif olarak şöyle deneyin.
[d7] hüccresine veri girdiğinizde çalışacaktır.

 Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [d7]) Is Nothing Then Exit Sub
'If Target = Empty Then Exit Sub
[d8] = ""
Set x = Sheets("planlama").[E8:Z61].Find(What:=[d7])
If Not x Is Nothing Then
    Application.EnableEvents = False
    fg = x.Address
    Do
    If Sheets("planlama").Cells(7, x.Column) >= [d5] And [d6] >= Sheets("planlama").Cells(7, x.Column) Then
    If Target = x.Value Then [d8] = Sheets("planlama").Cells(x.Row, x.Column).Offset(5, 0) + [d8]
End If
 Set x = Sheets("planlama").[E8:Z61].FindNext(x)
    Loop While Not x Is Nothing And x.Address <> fg
    Application.EnableEvents = True
End If
End Sub

 

[chngrcn]

Dosyanız ektedir, İnceleyiniz.. Saygılar..

Sub bul_topla()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim i As Long

Set s1 = Sheets("planlama")
Set s2 = Sheets("ozet")

s2.Range("K1:K65536").ClearContents

sat1 = s1.Cells(65536, "E").End(xlUp).Row
sat2 = s2.Cells(65536, "K").End(xlUp).Row



Application.ScreenUpdating = False
For i = 7 To s1.Cells(5, s1.Columns.Count).End(xlToLeft).Column
    If s1.Cells(7, i).Value >= CDate(s2.Cells(5, 4).Value) And _
    s1.Cells(7, i).Value <= CDate(s2.Cells(6, 4).Value) Then
        For y = 26 To sat1
        If s1.Cells(y, i).Value = s2.Cells(7, 4).Value Then
            s2.Cells(sat2, 11).Value = s1.Cells(y + 5, i).Value
                sat2 = sat2 + 1
               End If
           Next y
        End If
    Next i
    
   s2.Cells(8, 4).Value = WorksheetFunction.Sum(s2.Range("K1:K20"))
    
MsgBox " işlem tamamdır...", , ""
Application.ScreenUpdating = True


End Sub

 

[TİKOS]

Üstat çok teşekkür ederim. ellerine sağlık
Yanlız ufak bir probelm var, Mesela Mermak yada Kent döküm yazdığımda verileri getirmiyor.
Diğerlerinde problem yok.
İlgilenebilirsen çok sevinirim.

 

[TİKOS]

Hsgvarna hocam sizi kodları kullandım
bir sonuç vermedi.

 

[Husgvarna]

Ek dosyayı incelermisiniz. Hücreye veriyi büyük harfle yazın

 

[TİKOS]

çok teşekkür ederim.
Her ikinizde
iyi çalışmalar