• DİKKAT

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

stok koduna göre toparlama

  • Konbuyu başlatan Konbuyu başlatan ThEeNCi
  • Başlangıç tarihi Başlangıç tarihi
ThEeNCi

ThEeNCi

Katılım
15 Mart 2010
Mesajlar
244
Excel Vers. ve Dili
2019 Türkçe
Selamlar

Stok koduna göre toparlama yapabilen macro nasıl yapabilirim

Teşekkürler
 

Ekli dosyalar

Stok koduna göre demişsiniz ama örneğinizde sadece stok koduna göre işlem yapmamışsınız. Örneğin istenen kısmında DEM stok kodu 2 kere geçiyor. Neye göre olacak?
 
Yusuf bey aşağıda istenen şekli diye örnek vermiştim
 
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub aktar59()
Dim sh As Worksheet, sonsat As Long, i As Long
Dim z As Object, liste, myarr, n As Long
Sheets("DATA").Select
Set sh = Sheets("RAPOR")
sh.Range("A3:G" & Rows.Count).ClearContents
sonsat = Cells(Rows.Count, "C").End(xlUp).Row
liste = Range("A3:G" & sonsat).Value
ReDim myarr(1 To 7, 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 3) & liste(i, 4)) Then
        n = n + 1
        z.Add liste(i, 3) & liste(i, 4), n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(3, n) = liste(i, 3)
        myarr(4, n) = liste(i, 4)
    End If
    myarr(5, z.Item(liste(i, 3) & liste(i, 4))) = _
            myarr(5, z.Item(liste(i, 3) & liste(i, 4))) + liste(i, 5)
    myarr(6, z.Item(liste(i, 3) & liste(i, 4))) = _
            myarr(6, z.Item(liste(i, 3) & liste(i, 4))) + liste(i, 6)
    myarr(7, z.Item(liste(i, 3) & liste(i, 4))) = _
            myarr(7, z.Item(liste(i, 3) & liste(i, 4))) + liste(i, 7)
Next i
Erase liste
Application.ScreenUpdating = False
ReDim Preserve myarr(1 To 7, 1 To z.Count)
If z.Count > 0 Then
    sh.Range("A3").Resize(z.Count, 7) = Application.Transpose(myarr)
End If
Erase myarr
Set z = Nothing
sh.Select
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "RAPOR Çıkarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Evren bey elinize sağlık istediğim gibi olmuş ama kdv ve toplam satışı getirmiyor boş bırakmış bir data daki aynı net satış tutarını getirdiği gibi gelmesi lazım teşekkürler
 
ThEeNCi' Alıntı:
Evren bey elinize sağlık istediğim gibi olmuş ama kdv ve toplam satışı getirmiyor boş bırakmış bir data daki aynı net satış tutarını getirdiği gibi gelmesi lazım teşekkürler
Genişletmek için tıkla ...

Dosyayı güncelledim.
4 nolu mesajdan indirebilirsiniz.:cool:
 
Çok teşekkür ederim ellerinize sağlık
 
Orion1' Alıntı:
Rica ederim.
iyi çalışmalar.:cool:
Genişletmek için tıkla ...

Elinize Saglık hocam,

Bende bir dosya ekledim, mükerrer kayıtlar mevcut

img

Resimdede gördügünüz gibi

İstiyorumki A ve D sütununa baksın kayıt mükerrer ise
B sütunundaki bu güne en yakın tarihli kayıtı rapor yapsın bana
Eğer yapabilirseniz çok mutlu olurum şimdiden teşekkür ederim.
 

Ekli dosyalar

newmaster' Alıntı:
Elinize Saglık hocam,

Bende bir dosya ekledim, mükerrer kayıtlar mevcut

img

Resimdede gördügünüz gibi

İstiyorumki A ve D sütununa baksın kayıt mükerrer ise
B sütunundaki bu güne en yakın tarihli kayıtı rapor yapsın bana
Eğer yapabilirseniz çok mutlu olurum şimdiden teşekkür ederim.
Genişletmek için tıkla ...

Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub listele59()
Dim sh As Worksheet, z As Object, liste, myarr, i As Long
Dim sonsat As Long, n As Long
Sheets("Sayfa1").Select
sonsat = Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:D" & sonsat).Sort key1:=Range("D2"), order1:=xlAscending, _
        key2:=Range("B2"), order2:=xlAscending
Set sh = Sheets("Rapor")
sh.Range("A2:D" & Rows.Count).ClearContents
liste = Range("A2:D" & sonsat).Value
ReDim myarr(1 To 4, 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 4)) Then
        n = n + 1
        z.Add liste(i, 4), n
        myarr(4, n) = liste(i, 4)
    End If
    myarr(1, z.Item(liste(i, 4))) = liste(i, 1)
    myarr(2, z.Item(liste(i, 4))) = liste(i, 2)
    myarr(3, z.Item(liste(i, 4))) = liste(i, 3)
Next i
Erase liste
ReDim Preserve myarr(1 To 4, 1 To z.Count)
If z.Count > 0 Then sh.Range("A2").Resize(z.Count, 4) = Application.Transpose(myarr)
Erase myarr: Set z = Nothing
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "Benzersiz veriler yakın tarihe göre aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
 

Ekli dosyalar

Orion1' Alıntı:
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub listele59()
Dim sh As Worksheet, z As Object, liste, myarr, i As Long
Dim sonsat As Long, n As Long
Sheets("Sayfa1").Select
sonsat = Cells(Rows.Count, "D").End(xlUp).Row
Application.ScreenUpdating = False
Range("A2:D" & sonsat).Sort key1:=Range("D2"), order1:=xlAscending, _
        key2:=Range("B2"), order2:=xlAscending
Set sh = Sheets("Rapor")
sh.Range("A2:D" & Rows.Count).ClearContents
liste = Range("A2:D" & sonsat).Value
ReDim myarr(1 To 4, 1 To sonsat)
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    If Not z.exists(liste(i, 4)) Then
        n = n + 1
        z.Add liste(i, 4), n
        myarr(4, n) = liste(i, 4)
    End If
    myarr(1, z.Item(liste(i, 4))) = liste(i, 1)
    myarr(2, z.Item(liste(i, 4))) = liste(i, 2)
    myarr(3, z.Item(liste(i, 4))) = liste(i, 3)
Next i
Erase liste
ReDim Preserve myarr(1 To 4, 1 To z.Count)
If z.Count > 0 Then sh.Range("A2").Resize(z.Count, 4) = Application.Transpose(myarr)
Erase myarr: Set z = Nothing
Application.ScreenUpdating = True
sh.Select
Set sh = Nothing
MsgBox "Benzersiz veriler yakın tarihe göre aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
Genişletmek için tıkla ...

Hocam elleriniz dert görmesin tek bir sorunum var
mesela ÇELİKTEN GIDA DAĞITIM firmanın tek ürününü veriyor normalde 7 farklı kalem ürünü mevcut ben net anlatamadım sanırım ondan oldu böyle,
Mesela bir cari 1 ürünü ay içerisinde 5 defa sipariş verebiliyor benim istedigim aynı üründe en son aldıgını bulmak bunu yapma imkanınız varsa sevinirim.
Anlasılabilir olması için dosyayı ekledim sarı ile boyadıklarım ürünü birden fazla almıs ama en son aldıgı tarihi gösteriyor
 

Ekli dosyalar

Evren bey tekrar selamlar aynı dosyada başka toparlama yapmak istedim yalnız bu sever fiş no da bulunan numaraların başında A harfi olmadığı için bütün hepsini tek satırda toplardı
 

Ekli dosyalar

ThEeNCi' Alıntı:
Evren bey tekrar selamlar aynı dosyada başka toparlama yapmak istedim yalnız bu sever fiş no da bulunan numaraların başında A harfi olmadığı için bütün hepsini tek satırda toplardı
Genişletmek için tıkla ...

Kodlar fiş noyu baz almıyor.C ve D sütununu baz alıyor.:cool:
 
Peki neden olmuyor bu sefer b sutunundaki bütün numaraları bir numaraya topluyor
 
ThEeNCi' Alıntı:
Peki neden olmuyor bu sefer b sutunundaki bütün numaraları bir numaraya topluyor
Genişletmek için tıkla ...

Siz C ve D sütunlardaki mükerrerliği aramıyormusunuz?
Ne istiyorsunuz?Ben isteğinizi yapmıştım.:cool:
 
newmaster' Alıntı:
Hocam elleriniz dert görmesin tek bir sorunum var
mesela ÇELİKTEN GIDA DAĞITIM firmanın tek ürününü veriyor normalde 7 farklı kalem ürünü mevcut ben net anlatamadım sanırım ondan oldu böyle,
Mesela bir cari 1 ürünü ay içerisinde 5 defa sipariş verebiliyor benim istedigim aynı üründe en son aldıgını bulmak bunu yapma imkanınız varsa sevinirim.
Anlasılabilir olması için dosyayı ekledim sarı ile boyadıklarım ürünü birden fazla almıs ama en son aldıgı tarihi gösteriyor
Genişletmek için tıkla ...

1nci ve 4ncü sütunlarda mükerrerlik arandı ve son tarihli satırlar listelendi.
Dosya ektedir.:cool:
 

Ekli dosyalar

Orion1' Alıntı:
1nci ve 4ncü sütunlarda mükerrerlik arandı ve son tarihli satırlar listelendi.
Dosya ektedir.:cool:
Genişletmek için tıkla ...

Nekadar teşekkür etsem azdır, Allah ne muradın varsa versin ellerine saglık

bu tarz egitimi ben nereden ögrenebilirim forumdaki video bölümü işimi görürmü
 
Levent bey sanırım b sutunu daki numaraya göre stok kodundaki farka göre ve müşteri ismine göre toparlama yapması lazım
 
Levent bey c sutunu için verdiğin numarayı b sunutu olarak değiştirdim şimdi oldu :) çok teşekkür ederim ilginiz için
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst