Aynı olanları toplama ve fiyat getirme.

[unalh]

S.a Arkadaşlar,

Yapmakta olduğum bir çalışmada iki tane soru sormak istiyorum.

1-) Bir klasör içersinde olan (Aynı Olanları Toplama.xls) içersinde sayfa1 de aktar düğmesine basınca o sayfada olan kayıtlar içersinde B kolonu dikkate alınarak aynı olan kodları toplayıp teke indirgedikten sonra Toplamlar sayfasına aktarması.

2-) Toplamlar sayfasında Fiyatları getir düğmesine basınca fiyatlar klasörü içersindeki dosyadan fiyatı olan ürünlerin karşılarına yazılması.

Biraz karmaşık gibi oldu umarım tam anlatabilmişimdir.

İlginize teşekkür ederim.

 

[unalh]

:yardim: .

 

[Orion1]

Dosyanız ektedir.

Sub kapali_tekrarsiz_59()
Dim conn As ADODB.Connection, rs As ADODB.Recordset, z As Object
Dim myarr(), n As Long
'Microsoft activex object library 2.x eklendi
Sheets("Sayfa1").Select
Range("A2:F65536").ClearContents
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set z = CreateObject("Scripting.Dictionary")
conn.Open "Provider=microsoft.jet.oledb.4.0;Data source=" & ThisWorkbook.Path & "\Fiyatlar\Fiyat Listesi.xls;extended properties=""excel 8.0;hdr=no"""
rs.Open "Select * from [Sayfa1$A2:D65536];", conn, adOpenKeyset, adLockReadOnly
ReDim myarr(1 To 5, 1 To 65536)
If rs.RecordCount > 1 Then rs.MoveFirst
Do While Not rs.EOF
    If Not z.exists(rs(1).Value) Then
        n = n + 1
        z.Add rs(1).Value, n
        myarr(1, n) = rs(0).Value
        myarr(2, n) = rs(1).Value
        myarr(3, n) = rs(2).Value
    End If
    myarr(4, z.Item(rs(1).Value)) = myarr(4, z.Item(rs(1).Value)) + 1
    myarr(5, z.Item(rs(1).Value)) = myarr(5, z.Item(rs(1).Value)) + rs(3).Value

    rs.MoveNext
Loop
rs.Close: conn.Close
Set rs = Nothing
Set conn = Nothing
If n > 0 Then
    Range("A2").Resize(n, 5) = Application.Transpose(myarr)
    Set z = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    Exit Sub
End If
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "Aktarım yapılamadı.", vbCritical, "UYARI"
End Sub

 

[İhsan Tank]

:yardim: .

merhaba
ben formül ile bir çözüm buldum bütün formüller 100 satır'a kadar yapılmıştır.
dosya içerisinde açıklama ekledim anlamdığınız bir yer olursa sorunuz

 

[Orion1]

Tekrar sayısını yazdırmayı atlamışım.
Onu düzelttim.
3 numralı mesajdan dosyayı indirebilirsiniz.

 

[unalh]

Evren hocam öncelikle ilginiz için teşekkür ederim

Yanlış anlattım galiba yapmak istediğim şu aynı olanlar sayfasındaki adetleri Toplamlar sayfasına toplamak (Benzersiz olarak) sonrasında fiyat bölümünden sadece fiyatları alması fiyat kısımlarını toplamayacak.
Eğer fiyat listesinde o ürünün fiyatı varise karşılığına yazması

 

[Orion1]

Evren hocam öncelikle ilginiz için teşekkür ederim

Yanlış anlattım galiba yapmak istediğim şu aynı olanlar sayfasındaki adetleri Toplamlar sayfasına toplamak (Benzersiz olarak) sonrasında fiyat bölümünden sadece fiyatları alması fiyat kısımlarını toplamayacak.
Eğer fiyat listesinde o ürünün fiyatı varise karşılığına yazması

5 numaralı mesajımı okuyun.Sonra dönüş yapınız.

 

[unalh]

Hocam mesajı gördüm aynı olanları topla.xls içersindeki sayfa1 de olan verilerin Toplamlar bölümüne Toplanması sonrasında Fiyat Listesi klasöründen de karşılarına fiyatları alması gerekiyor.

 

[Orion1]

Hocam mesajı gördüm aynı olanları topla.xls içersindeki sayfa1 de olan verilerin Toplamlar bölümüne Toplanması sonrasında Fiyat Listesi klasöründen de karşılarına fiyatları alması gerekiyor.

Yani 2 butonmu olacak
Bir buton ile tekrarsız veriler yani kod nolar alınacak
diğer butona basıncada kapalı dosyadaki verilerin toplamları o sayfada toplamlara toplanacak.Doğrumudur?

 

[unalh]

Birinci buton Sayfa birdeki verileri toplamlar sayfasına kodlara bakarak toplayacak burası doğru.
İkinci buton fiyatlistesine bakacak eğer o ürünün fiyat listesinde fiyatı varsa karşısına fiyatını yazacak.

 

[Orion1]

Birinci buton Sayfa birdeki verileri toplamlar sayfasına kodlara bakarak toplayacak burası doğru.
İkinci buton fiyatlistesine bakacak eğer o ürünün fiyat listesinde fiyatı varsa karşısına fiyatını yazacak.

Sanırım konuyu anlayabildim.
Ekli dosyayı kopntrol ediniz.Bakalım istediğiniz olmuşmu?

Sub kapali_fiyat_al_59()
Dim conn As ADODB.Connection, rs As ADODB.Recordset, z As Object
Dim sat As Long
'Microsoft activex object library 2.x eklendi
Sheets("Toplamlar").Select
Range("D2:E65536").ClearContents
Application.ScreenUpdating = False
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set z = CreateObject("Scripting.Dictionary")
conn.Open "Provider=microsoft.jet.oledb.4.0;Data source=" & ThisWorkbook.Path & "\Fiyatlar\Fiyat Listesi.xls;extended properties=""excel 8.0;hdr=no"""
rs.Open "Select * from [Sayfa1$B2:D65536];", conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 1 Then rs.MoveFirst
Do While Not rs.EOF
    If Not z.exists(rs(0).Value & "-" & rs(1).Value) Then
        z.Add rs(0).Value & "-" & rs(1).Value, rs(2).Value
    End If
    rs.MoveNext
Loop
rs.Close: conn.Close
Set rs = Nothing
Set conn = Nothing
sat = Cells(65536, "B").End(xlUp).Row
If z.Count > 0 Then
    On Error Resume Next
    For i = 2 To sat
        Cells(i, "E").Value = ""
        Cells(i, "E").Value = z.Item(Cells(i, "B").Value & "-" & _
        Cells(i, "C").Value)
    Next
    On Error GoTo 0
    Set z = Nothing
    Application.ScreenUpdating = True
    MsgBox "İşlem tamamlandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    Exit Sub
End If
Set z = Nothing
Application.ScreenUpdating = True
MsgBox "Aktarım yapılamadı.", vbCritical, "UYARI"
End Sub
Sub Fiyat_Topla_59()
Dim z As Object, sat As Long, i As Long, sh As Worksheet
Sheets("Sayfa1").Select
Range("E2:E65536").ClearContents
Application.ScreenUpdating = False
Set sh = Sheets("Toplamlar")
sat1 = Cells(65536, "B").End(xlUp).Row
sat2 = sh.Cells(65536, "B").End(xlUp).Row
Set z = CreateObject("Scripting.dictionary")
For i = 2 To sat2
    If sh.Cells(i, "E").Value > 0 Then
        If Not z.exists(sh.Cells(i, "B").Value & "-" _
        & sh.Cells(i, "C").Value) Then
            z.Add sh.Cells(i, "B").Value & _
            "-" & sh.Cells(i, "C").Value, sh.Cells(i, "E").Value
        End If
    End If
Next i
On Error Resume Next
For i = 2 To sat1
    Cells(i, "E").Value = ""
    Cells(i, "E").Value = z.Item(sh.Cells(i, "B").Value _
    & "-" & sh.Cells(i, "C").Value) * Cells(i, "D").Value
Next i
On Error GoTo 0
Application.ScreenUpdating = True
If z.Count > 0 Then
    MsgBox "İşlem tamamlandı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
    Else
    MsgBox "işlem gerçekleşmedi.", vbCritical, "UYARI"
End If
Set z = Nothing
End Sub

 

[unalh]

S.a Evren hocam öncelikle hayırlı sabahlar,

Fiyatları getir butonu tamam istediğim gibi çok teşekkür ederim.

Yanlız birinci sayfadaki rapor butonunu resimde anlatmaya çalıştım eğer o şekilde olabilirse çok sevinirim.
Sayfa1 deki listeyi toplamlar sayfasına aktarıcak aktarırken aynı koddaki ürünlerin adetlerini birleştirecek.




Emekleriniz için tekrar teşekkür ederim.

 

[Orion1]

Peki ürün sayfa1 de varsa toplamlar sayfasında yoksa ne olacak.
Ayrıca sayfa1 e ürünleri siz manuelmi gireceksiniz?

 

[unalh]

Düşünün Şubeleriniz var size buralardan stok adet bilgileri geliyor şube sayınız nekadar fazla ise aynı kodlu ürünlerin olma sayısıda okadar fazla.
Yani sayfa1'de birkaç yerden alınan stok bilgileri mevcut.
Toplamlar sayfasını tamamen boş düşünün çünkü yapmak istediğim zaten sayfa1 deki ürünlerin birleşimini Toplamlar sayfasına aktarmak.
Sıralama şöyle;
1-Ürünler sayfa1'e girilir
2-Girilen ürünler Toplamlar sayfasına aktarılır.

 

[Orion1]

V3 versiyonunu deneyin .Bakalım istediğiniz olmuşmu?
Benim için kod yazmak problem değil.Önemli olan soruyu anlamak.
Soruyu anlasam 12'den vururum.1 kerde çıkarrıırım işi.

 

[unalh]

Hocam şöyle anlatayım
Elinizde bir liste mevcut 2000 satır aynı ürünlerden farklı satırlarda var sizden bunu başka bir sayfaya aynı üründen tekbir tane olarak listelemeniz isteniyor tabi atetleri toplayarak yapmaya çalıştığım şey bu.
Gönderdiğiniz V3 Toplama yapıyor doğru ama Toplam sayfasını boş olarak düşünün rapor yap dediğimizde sayfa1 deki verileri toplamlar sayfasına aktarıcak adetleri toplayarak.

 

[İhsan Tank]

Hocam şöyle anlatayım
Elinizde bir liste mevcut 2000 satır aynı ürünlerden farklı satırlarda var sizden bunu başka bir sayfaya aynı üründen tekbir tane olarak listelemeniz isteniyor tabi atetleri toplayarak yapmaya çalıştığım şey bu.
Gönderdiğiniz V3 Toplama yapıyor doğru ama Toplam sayfasını boş olarak düşünün rapor yap dediğimizde sayfa1 deki verileri toplamlar sayfasına aktarıcak adetleri toplayarak.

merhaba
syn : unalh
benim eklediğim dosya işinizi görmedimi_? formül ile yapmıştım.

 

[unalh]

İhsan bey merhaba kusura bakmayın sizin cavabınız için dönüş yapamadım.


Sizin yaptığız dosya benim istediğim mantıkla çalışıyor elinize sağlık.
Bir eksik adetlerin toplamlarını almıyor.
Ürün sayısı fazla olunca formül olayı kastırıyor.
Bu nedenle kod daha mantıklı ve daha pratik.

İlginize teşekkür ederim.

 

[İhsan Tank]

İhsan bey merhaba kusura bakmayın sizin cavabınız için dönüş yapamadım.


Sizin yaptığız dosya benim istediğim mantıkla çalışıyor elinize sağlık.
Bir eksik adetlerin toplamlarını almıyor.
Ürün sayısı fazla olunca formül olayı kastırıyor.
Bu nedenle kod daha mantıklı ve daha pratik.

İlginize teşekkür ederim.

tmm sağolun bilgi verdiğiniz için.

 

[Orion1]

Hocam şöyle anlatayım
Elinizde bir liste mevcut 2000 satır aynı ürünlerden farklı satırlarda var sizden bunu başka bir sayfaya aynı üründen tekbir tane olarak listelemeniz isteniyor tabi atetleri toplayarak yapmaya çalıştığım şey bu.
Gönderdiğiniz V3 Toplama yapıyor doğru ama Toplam sayfasını boş olarak düşünün rapor yap dediğimizde sayfa1 deki verileri toplamlar sayfasına aktarıcak adetleri toplayarak.

Sanırım bu sefer oldu.
Dosyayı 15nci mesaja ekledim.