[Yardım]  B kolonundaki aynı verileri birleştirme, D kolonunu toplama

VBA Makrolar ile ilgili sormak istedikleriniz, yapmak istedikleriniz hakkında yardım alabileceğiniz bölümdür.

B kolonundaki aynı verileri birleştirme, D kolonunu toplama

İleti#1)  digitalkral » 08 Tem 2018 22:22

Merhaba,

Ben bir adet stok takip ve satış programı yapıyorum. Bir fonksiyonu hariç diğer fonksiyonlarını hazırladım.
Benim şu an yardıma ihtiyacım olan konuyu şöyle anlatayım.


Eldeki veriler.
"SATILANLAR" sayfasında;
1- B kolonunda ürünlerin ismi,
2- C kolonunda ürünün fiyatı,
3- D kolonunda satış miktarı var.

İstediğim sonuç "GÜN SONU" penceresindeki "GÜN SONU" butonuna bastığımda "SATILANLAR" sayfasında
1- B kolonundaki aynı isimli ürünleri birleştirip 1 tane bırakacak ve B kolonuna yazılacak
2- C kolonundaki fiyat aynı kalacak ve C kolonuna ilgili ürünle aynı satıra ürünün fiyatı yazılacak
3- D kolonundaki satış miktarları toplanacak ve yine D koluna ilgili ürünle aynı satıra ürünün satış miktarı yazılacak.

Şuan dosyada bu istediğimi yapabiliyorum ama kodlar optimize değil hataları var.
Şöyle ki 1 defa birleştirme yapıldığında sorun yok ama birleştirme yapıldıktan sonra tekrar butona basarsam birleştirilen satış olmamasına rağmen satılan adeti tekrar arttırıyor.

İkinci bir amacımda "GÜN SONU" penceresindeki "STOK AKTAR" butonuna bastığımda "SATILANLAR" sayfasındaki D kolonunda bulunan satılan ürünlerin adetlerini "STOK" sayfasındaki ilgili ürünün E kolonundaki "SATILANLAR" kolonuna yazmasını ve stok miktarından düşmesini ve "SATILANLAR" SAYFASINI temizlemesini istiyorum. Şu ana kadar bunu başaramadım.

Ekte hazırladığım dosyanın tam hali var.
Yardımcı olursanız çok sevinirim.
Saygılar...
Bu iletideki ekleri görmek için gerekli yetkilere sahip değilsiniz.
Kullanıcı avatarı
digitalkral
 
Adı Soyadı:Serkan TÜKENMEZ
Kayıt: 25 Haz 2012 17:14
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İZMİR

Cevap: B kolonundaki aynı verileri birleştirme, D kolonunu t

İleti#2)  digitalkral » 08 Tem 2018 23:02

GÜN SONU butonunu
Kod: Tümünü seç
Sheets("SATILANLAR").Select
Dim son As Long
son = Sheets("SATILANLAR").Cells(Rows.Count, "B").End(xlUp).Row
If son > 1 Then
Dim sonsat As Long, z As Object, liste(), deg As String
Dim sh As Worksheet, n As Long, myarr(), i As Long
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
ReDim myarr(1 To 5, 1 To sonsat)
liste = Range("A2:E" & sonsat).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    deg = liste(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(3, n) = liste(i, 3)
        myarr(1, n) = liste(i, 4)
        myarr(1, n) = liste(i, 5)
    End If
    myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + liste(i, 4)
    myarr(5, z.Item(deg)) = myarr(5, z.Item(deg)) + liste(i, 5)
Next i
Erase liste: Set z = Nothing
Range("A2:E" & Rows.Count).ClearContents
Application.ScreenUpdating = False
ReDim Preserve myarr(1 To 5, 1 To n)
Range("A2").Resize(n, 5) = Application.Transpose(myarr)
Range("C:C").Select
Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
Range("A1").Select
Application.ScreenUpdating = True
Else
End If

son = Sheets("SATILANLAR").Cells(Rows.Count, "B").End(xlUp).Row
Dim cell As Range
Range("C2:E" & son).Select
For Each cell In Selection
If Not IsEmpty(cell) And IsNumeric(cell.Value) Then
cell.Value = CDbl(cell.Value)
End If
Next cell
Application.ScreenUpdating = True





STOK AKTAR butonu
Kod: Tümünü seç
Dim son As Long
Dim son2 As Long
son = Sheets("SATILANLAR").Cells(Rows.Count, "B").End(xlUp).Row
If son > 1 Then
Sheets("SATILANLAR").Select
Range("B2:B" & son).Select
Selection.Copy
Sheets("STOK").Select
son2 = Sheets("STOK").Cells(Rows.Count, "B").End(xlUp).Row
Range("B" & son2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Sheets("SATILANLAR").Select
Range("D2:D" & son).Select
Selection.Copy
Sheets("STOK").Select
son2 = Sheets("STOK").Cells(Rows.Count, "D").End(xlUp).Row
Range("D" & son2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Dim sonsat As Long, z As Object, liste(), deg As String
Dim sh As Worksheet, n As Long, myarr(), i As Long
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
ReDim myarr(1 To 5, 1 To sonsat)
liste = Range("A2:E" & sonsat).Value
Set z = CreateObject("Scripting.dictionary")
For i = 1 To UBound(liste)
    deg = liste(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 2)
        myarr(3, n) = liste(i, 3)
        myarr(1, n) = liste(i, 4)
        myarr(1, n) = liste(i, 5)
    End If
    myarr(4, z.Item(deg)) = liste(i, 4) + myarr(4, z.Item(deg))
    myarr(5, z.Item(deg)) = liste(i, 5) + myarr(5, z.Item(deg))
Next i
Erase liste: Set z = Nothing
Range("A2:K" & Rows.Count).ClearContents
Application.ScreenUpdating = False
ReDim Preserve myarr(1 To 5, 1 To n)
Range("A2").Resize(n, 5) = Application.Transpose(myarr)
Range("C:C").Select
Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
Range("A1").Select
Application.ScreenUpdating = True
Else
End If

Kullanıcı avatarı
digitalkral
 
Adı Soyadı:Serkan TÜKENMEZ
Kayıt: 25 Haz 2012 17:14
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İZMİR

Cevap: B kolonundaki aynı verileri birleştirme, D kolonunu t

İleti#3)  digitalkral » 11 Tem 2018 20:01

Tüm istediklerimi yaptım. Sorun çözüldü.
Kullanıcı avatarı
digitalkral
 
Adı Soyadı:Serkan TÜKENMEZ
Kayıt: 25 Haz 2012 17:14
İleti: 6
 
Cinsiyet: Bay
Bulunduğunuz İl / Semt: İZMİR


Forum Genel Makro Soruları

Online Kullanıcılar

Bu forumu görüntüleyenler: AhrefsBot ve 2 misafir

Bumerang - Yazarkafe