• DİKKAT

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

Sipariş no ve tarihe göre veri arama toplama

A

alper81

Katılım
7 Kasım 2006
Mesajlar
67
Excel Vers. ve Dili
alper81
Sayın üstadlarım sayfa1 deki tabloda 2 çeşit arama yaptırıp verileri toplamasını nasıl yaptırabilirim. yardımlarınızı bekliyorum
 

Ekli dosyalar

ekteki dosyada istediğimi işaretledim ve yazdım. yardımlarınız için teşekkürler
 

Ekli dosyalar

Son düzenleme:
alper81' Alıntı:
ekteki dosyada istediğimi işaretledim ve yazdım. yardımlarınız için teşekkürler
Genişletmek için tıkla ...

merhaba
e2 hücresine
=TOPLA.ÇARPIM(('NO 1'!$B$2:$B$32=Sayfa1!$A2)*('NO 1'!$A$2:$A$32=Sayfa1!E$1);('NO 1'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 2'!$B$2:$B$32=Sayfa1!$A2)*('NO 2'!$A$2:$A$32=Sayfa1!E$1);('NO 2'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 3'!$B$2:$B$32=Sayfa1!$A2)*('NO 3'!$A$2:$A$32=Sayfa1!E$1);('NO 3'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 4'!$B$2:$B$32=Sayfa1!$A2)*('NO 4'!$A$2:$A$32=Sayfa1!E$1);('NO 4'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 5'!$B$2:$B$32=Sayfa1!$A2)*('NO 5'!$A$2:$A$32=Sayfa1!E$1);('NO 5'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 6'!$B$2:$B$32=Sayfa1!$A2)*('NO 6'!$A$2:$A$32=Sayfa1!E$1);('NO 6'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 7'!$B$2:$B$32=Sayfa1!$A2)*('NO 7'!$A$2:$A$32=Sayfa1!E$1);('NO 7'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 8'!$B$2:$B$32=Sayfa1!$A2)*('NO 8'!$A$2:$A$32=Sayfa1!E$1);('NO 8'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 9'!$B$2:$B$32=Sayfa1!$A2)*('NO 9'!$A$2:$A$32=Sayfa1!E$1);('NO 9'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 10'!$B$2:$B$32=Sayfa1!$A2)*('NO 10'!$A$2:$A$32=Sayfa1!E$1);('NO 10'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 11'!$B$2:$B$32=Sayfa1!$A2)*('NO 11'!$A$2:$A$32=Sayfa1!E$1);('NO 11'!$H$2:$H$32))+TOPLA.ÇARPIM(('NO 12'!$B$2:$B$32=Sayfa1!$A2)*('NO 12'!$A$2:$A$32=Sayfa1!E$1);('NO 12'!$H$2:$H$32))
Genişletmek için tıkla ...
bu formülü yazın
dosya ekte
 

Ekli dosyalar

Son düzenleme:
çok teşekkürler ihsan bey sayenizde çok güzel bir hal aldı çok saolun
 
Dosyanız ektedir.:cool:
No ile başlayan sayfa adlarınfakilerde işlem yapıldı.:cool:
Kod: 
Sub siparis_toplam_59()
Dim sh As Worksheet, i As Long, sat1 As Long, sat2 As Long
Dim z As Object, sut As Integer, myarr(), j As Long, n As Long
Dim col As Collection, myarr2()
Set col = New Collection
Sheets("Sayfa1").Select
sut = Cells(1, "IV").End(xlToLeft).Column
If sut < 4 Then
    MsgBox "Tarih girilmemiş." & vbLf & "İşlem sona erdi", vbCritical, "UYARI"
    Exit Sub
End If
sat1 = Cells(65536, "A").End(xlUp).Row
If sat1 < 2 Then
    MsgBox "Sipariş no girilmemiş" & vbLf & "İşlem sona erdi", vbCritical, "UYARI"
    Range("A2").Select: Exit Sub
End If
For i = 5 To sut
    col.Add i - 4, CStr(CDate(Cells(1, i).Value))
Next i

Set z = CreateObject("Scripting.Dictionary")
For j = 2 To sat1
    If WorksheetFunction.CountIf(Range("A2:A" & sat1), Cells(j, "A").Value) > 1 Then
        MsgBox Cells(i, "A").Value & "Sipariş nosundan  2 tane var.Teke düşürerek devam ediniz." _
        & vbLf & "İşlem iptal edildi", vbCritical, "UYARI"
        Set z = Nothing
        Exit Sub
    End If
    If Not z.exists(Cells(j, "A").Value) Then
        If Cells(j, "A").Value <> "" Then
            n = n + 1
            z.Add Cells(j, "A").Value, n
        End If
    End If
Next
ReDim myarr(1 To sut - 4, 1 To n)
Application.ScreenUpdating = False
For Each sh In Worksheets
    If UCase(Left(sh.Name, 2)) = "NO" Then
        If sh.AutoFilterMode = True Then sh.AutoFilterMode = False
        sat2 = sh.Cells(65536, "B").End(xlUp).Row
        myarr2 = sh.Range("A1:H" & sat2).Value
        For i = 2 To sat2
            If Not z.exists(myarr2(i, 2)) Then
                If sh.Cells(i, "B").Value <> "" Then
                    n = n + 1
                    z.Add myarr2(i, 2), n
                    ReDim Preserve myarr(1 To sut - 4, 1 To n)
                End If
            End If
            For j = 2 To sat1
                If IsNumeric(myarr2(i, 8)) And myarr2(i, 2) <> "" Then
                        myarr(CInt(col(CStr(myarr2(i, 1)))), z.Item(myarr2(i, 2))) _
                        = myarr(CInt(col(CStr(myarr2(i, 1)))), z.Item(myarr2(i, 2))) + sh.Cells(i, "H").Value
                End If
            Next j
        Next i
        Erase myarr2
    End If
Next sh
Range("E2").Resize(n, sut - 4) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 

Ekli dosyalar

1-2 değişiklik yaparak dahada hızlandırdım.
Dosya 7nci mesajdadır.:cool:
 
Selamlar,

Alternatif olarak formülle hazırladığım örnek dosyayı incelermisiniz.

AA sütununda dinamik ad tanımlaması uygulaması yapılmıştır. Formül içinde bu ad tanımlaması kullanılmıştır.

Formül kurgusu için Sn. Ali beye çok teşekkür ederim.


E2 hücresine uygulayınız.

Kod: 
=TOPLA.ÇARPIM(--(S(KAYDIR(DOLAYLI("'"&Sayfalar&"'!A2:A100");SATIR(DOLAYLI("2:100"))-2;0;1))=E$1);--(S(KAYDIR(DOLAYLI("'"&Sayfalar&"'!B2:B100");SATIR(DOLAYLI("2:100"))-2;0;1))=$A2);S(KAYDIR(DOLAYLI("'"&Sayfalar&"'!H2:H100");SATIR(DOLAYLI("2:100"))-2;0;1)))
 

Ekli dosyalar

yardımlarınız için teşekkürler bi sorum daha olacak bu çalışmayı program haline getirebilirmiyiz
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst