ürün ve tonaj takip

[enrealman]

Merhaba, isteğimi gönderdiğim excel belgesi içinde kısa tarif etmeye çalıştım. yardımlarınız için şimdiden teşekkür ederim.

 

[İhsan Tank]

Merhaba, isteğimi gönderdiğim excel belgesi içinde kısa tarif etmeye çalıştım. yardımlarınız için şimdiden teşekkür ederim.

merhaba
Sayfa2 B1 hücresine

=EĞERSAY(Sayfa1!$J:$J;A1)

bu formülü
D1 hücresine

=ETOPLA(Sayfa1!$J:$J;A1;Sayfa1!$K:$K)

bu formülü yazınız
eki inceleyiniz

 

[Orion1]

Dosyanız ektedir.

Option Base 1
Sub tekrarsiz_topla_59()
Dim sat As Long, isim As String, yatan As Double
Dim liste(), myarr(), n As Long, i As Long, z As Object
Sheets("Sayfa2").Select
Range("A1:E65536").ClearContents
sat = Sheets("Sayfa1").Cells(65536, "J").End(xlUp).Row
If sat < 2 Then
    MsgBox "Sayfa1 de Kişi yok.İşlem iptal oldu", vbCritical, "UYARI"
    Exit Sub
End If
Set z = CreateObject("scripting.dictionary")
liste = Sheets("Sayfa1").Range("J2:K" & sat).Value
ReDim myarr(1 To 3, 1 To sat)
For i = 1 To UBound(liste)
    If liste(i, 1) <> "" Then
        isim = UCase(Replace(Replace(liste(i, 1), "i", "İ"), "ı", "I"))
        If Not z.exists(isim) Then
            n = n + 1
            z.Add isim, n
            myarr(1, n) = liste(i, 1)
        End If
        myarr(2, z.Item(isim)) = myarr(2, z.Item(isim)) + 1
        If liste(i, 2) <> "" And IsNumeric(liste(i, 2)) Then
            yatan = liste(i, 2)
            myarr(3, z.Item(isim)) = myarr(3, z.Item(isim)) + yatan
        End If
    End If
Next i
Erase liste
Set z = Nothing
Application.ScreenUpdating = False
Range("A1").Resize(n, 3) = Application.Transpose(myarr)
Application.ScreenUpdating = True
Erase myarr
MsgBox "İşlem Tamamdır.", vbOKOnly + vbInformation, "evrengizlen@hotmail.com"
End Sub

 

[enrealman]

Teşekkür ederim.

Aklınıza ve elinize sağlık. Tam istediğim gibi olmuş. Tekrar teşekkür ederim.

Dosyanız ektedir.

Option Base 1
Sub tekrarsiz_topla_59()
Dim sat As Long, isim As String, yatan As Double
Dim liste(), myarr(), n As Long, i As Long, z As Object
Sheets("Sayfa2").Select
Range("A1:E65536").ClearContents
sat = Sheets("Sayfa1").Cells(65536, "J").End(xlUp).Row
If sat < 2 Then
    MsgBox "Sayfa1 de Kişi yok.İşlem iptal oldu", vbCritical, "UYARI"
    Exit Sub
End If
Set z = CreateObject("scripting.dictionary")
liste = Sheets("Sayfa1").Range("J2:K" & sat).Value
ReDim myarr(1 To 3, 1 To sat)
For i = 1 To UBound(liste)
    If liste(i, 1) <> "" Then
        isim = UCase(Replace(Replace(liste(i, 1), "i", "İ"), "ı", "I"))
        If Not z.exists(isim) Then
            n = n + 1
            z.Add isim, n
            myarr(1, n) = liste(i, 1)
        End If
        myarr(2, z.Item(isim)) = myarr(2, z.Item(isim)) + 1
        If liste(i, 2) <> "" And IsNumeric(liste(i, 2)) Then
            yatan = liste(i, 2)
            myarr(3, z.Item(isim)) = myarr(3, z.Item(isim)) + yatan
        End If
    End If
Next i
Erase liste
Set z = Nothing
Application.ScreenUpdating = False
Range("A1").Resize(n, 3) = Application.Transpose(myarr)
Application.ScreenUpdating = True
Erase myarr
MsgBox "İşlem Tamamdır.", vbOKOnly + vbInformation, "evrengizlen@hotmail.com"
End Sub

 

[Orion1]

Rica ederim.
İyi çalışmalar.