DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
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
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
Çok teşekkür ederim ellerinize sağlık
Rica ederim.
iyi çalışmalar.![]()
Elinize Saglık hocam,
Bende bir dosya ekledim, mükerrer kayıtlar mevcut
![]()
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.
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
Dosyanız ektedir.
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
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ı
Kodlar fiş noyu baz almıyor.C ve D sütununu baz alıyor.![]()
Peki neden olmuyor bu sefer b sutunundaki bütün numaraları bir numaraya topluyor
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
1nci ve 4ncü sütunlarda mükerrerlik arandı ve son tarihli satırlar listelendi.
Dosya ektedir.![]()