makro ile bir saydan diğer sayfalara veri aktarsın ve toplasın

[puslukurt]

Ömer bey merhaba;
hatırlayacağınız üzere aşağıdaki kod çok güzel çalışıyor. başka bir programda da bu kodu kullanmak istiyorum. bu koda şöyle bir ilave yapabilirmiyiz.
giriş sayfasında bulunan b2 hücresine tarihi yazdık. b3 hücresine müşteri numarasını yazdık. b4 hücresinede miktarı yazdık ve makroyu çalıştırdığımızda ilgili hücreye miktarı yazıyor. benim istediğim mümkünse aynı tarihe aynı müşteriye ilave miktar yazdığımızda ilgili hücrede toplaması. Örneğin..

B2 hücresine 23.02.2012
B3 hücresine 1090 (müşteri no)
b4 hücresine 15 (miktar) yazdık ve makroyu çalıştırdığımızda ilgili hücreye 15 rakamını yazdı. daha sonra

B2 hücresine 23.02.2012
B3 hücresine 1090 (müşteri no)
b4 hücresine 20 (miktar) yazdığım ve makroyu çalıştırdığımda ilgili hücre bir önceki ile toplayarak yani 35 yazmasını istiyorum mümkünse. Şimdiden teşekkür ederim ömer bey




Sub gönder()
Dim syf As String, sat As Long, sut As Integer, c As Range

Application.ScreenUpdating = False

syf = Month(Range("B2"))
With Sheets(syf)

Set c = .Range("A:A").Find(Range("B3"), , xlValues, xlWhole)
If Not c Is Nothing Then
sat = c.Row
End If

Set c = .Rows(3).Find(Range("B2"), , xlValues, xlWhole)
If Not c Is Nothing Then
sut = c.Column
End If

.Cells(sat, sut) = Range("B4")
End With

Range("B3:B4").ClearContents
MsgBox "Aktarım Yapıldı"

Application.ScreenUpdating = True
End Sub

 

[puslukurt]

dosya ekledim

ekte dosyada daha iyi anlaşılacağınan inanıyorum. teşekkürler

 

[asi_kral]

Merhaba

Sayfa adları ayları mı temsil ediyor

 

[puslukurt]

evet. rakamlı olanlar ayları temsil ediyor.

 

[Husgvarna]

Kodlarınıza aşağıdaki kırmızı bölümü ekleyip deneyin.

 Sub gönder()
Dim syf As String, sat As Long, sut As Integer, c As Range
 
    Application.ScreenUpdating = False
 
    syf = Month(Range("B2")) 'tarih
 
    With Sheets(syf)
 
        Set c = .Range("A:A").Find(Range("B3"), , xlValues, xlWhole) 'müşteri no
        If Not c Is Nothing Then
            sat = c.Row
        End If
 
        Set c = .Rows(3).Find(Range("B2"), , xlValues, xlWhole) 'tarih
        If Not c Is Nothing Then
            sut = c.Column
        End If
 
        .Cells(sat, sut) = Range("B4") [COLOR="Red"]+ .Cells(sat, sut)[/COLOR] 'miktar
    End With
 
    Range("B3:B4").ClearContents 'müşteri no ve miktar
    MsgBox "Aktarım Yapıldı", , "Murat Bozkurt"
 
    Application.ScreenUpdating = True
End Sub

 

[puslukurt]

teşekkür ederim husgvarna oldu. Kolay gelsin

 

[asi_kral]

evet. rakamlı olanlar ayları temsil ediyor.

Merhaba
Elektrik gitti kodu gönderemedim. Alternatif olsun

------------------------------------

Option Explicit
Sub sayfaya_aktar_1967()
'Konu : Tarih ve Müşteri Numarasına Göre Aktarım
'Coder By : asi_kral_1967
'mail : m.batu.1967@gmail.com
Dim asi, kral
Dim a, b, c
Application.ScreenUpdating = False
Set asi = Sheets(Mid(Range("B2"), 4, 2))
a = WorksheetFunction.Index(asi.Range("A4:AJ" & Rows.Count), _
WorksheetFunction.Match(Range("B3"), asi.Range("A4:A" & Rows.Count), 0), _
WorksheetFunction.Match(Range("B2"), asi.Range("A3:AJ3"), 0))
For b = 4 To asi.Cells(Rows.Count, "A").End(xlUp).Row
For c = 6 To asi.Cells(3, Columns.Count).End(xlToLeft).Column
If asi.Cells(b, "A") = Range("B3") And asi.Cells(3, c) = Range("B2") Then
asi.Cells(b, c) = asi.Cells(b, c) + a
End If
Next
Next
Application.ScreenUpdating = True
MsgBox "İşlem Başarı İle Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

-----------------------------------

Dosyanız ekte