toplam aldırma ve veri aktarımı

[baygal]

merhabalar , ekteki örnek sayfada yapmak istediğimi anlatmaya çalıştım..yardımcı olursanız çok makbule geçecek..şimdiden çok teşekkürler...

 

[Rido66]

Sorunun nerde olduğunu belitmen gerekiyor

 

[baygal]

örnekle açıklayayım.veri sayfasında stok isimleri ve ana grupları var.sayfa2deki çalışma sayfamızda mavi alanda istediğimiz ana grupları veri sayfasındaki tanımlamalara göre yeşil alandaki stok isimlerini tanısın L stununa yazsın..aslında ben bunu çözdüm ama 2 hamle ile.
esas sorun aktarım işlemi...aktarımda şunu istiyorum sayfa2 deki verileri olduğu gibi sayfa3 e aktarsın...sonra ben sayfa2 de başka verilerle çalışma yapınca ( format aynı ). yeni çalışmayı daha önce aktardığımız verinin altına eklesin...böyle her aktardığım veri sona eklenerek gitsin..
bu site de bu aktarıma benzer çalışmalar gördüm..ama tam karşılığı değil
yardımcı olursanız çok sevinirim..kolay gelsin

 

[Orion1]

Dosyanız ektedir.

Sub bolumle_59()
Dim sat As Long, i As Long, k As Range, s1 As Worksheet, s3 As Worksheet
Dim sat11 As Long, sat2 As Long, bolum As String
Sheets("Sayfa2").Select
Range("L3:O65536").ClearContents
Set s1 = Sheets("VERİ")
Set s3 = Sheets("Aktarım")
sat11 = s1.Cells(65536, "A").End(xlUp).Row
sat2 = Cells(65536, "K").End(xlUp).Row
sat3 = s3.Cells(65536, "A").End(xlUp).Row + 1
sat4 = s3.Cells(65536, "K").End(xlUp).Row + 1
sat = Cells(65536, "C").End(xlUp).Row
If sat < 4 Then Exit Sub
Application.ScreenUpdating = False
For i = 4 To sat
    Set k = s1.Range("A2:A" & sat11).Find(Cells(i, "C").Value, , xlValues, xlWhole)
    If Not k Is Nothing Then bolum = k.Offset(0, 1).Value
    Set k = Range("K2:K" & sat2).Find(bolum, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Cells(k.Row, "L").Value = Cells(k.Row, "L").Value + Cells(i, "E").Value
        Cells(k.Row, "M").Value = Cells(k.Row, "M").Value + Cells(i, "H").Value
    End If
Next i
If sat + sat3 > 65533 Then
    MsgBox "Detaylar sayfasında Yer kalmadı." & vbLf & _
    "Detaylar aktarılmadı", vbCritical, "UYARI"
    Else
    Range("C4:I" & sat).Copy s3.Range("A" & sat3)
    Range("C4:I" & sat).ClearContents
End If
If sat2 + sat4 > 65533 Then
    MsgBox "Toplamlar sayfasında Satır doldu" & vbLf & _
    "Toplamlar aktarılmadı", vbCritical, "UYARI"
    Else
    Range("K3:O" & sat2).Copy s3.Range("K" & sat4)
    Range("K3:O" & sat2).ClearContents
End If
Application.ScreenUpdating = True
MsgBox "İşlem tamamlanmıştır." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[baygal]

elinize sağlık istediğim gibi olmuş.sadece şunu da istesem sizden..aktarım 2 farklı sayfaya yapılmış..eğer mümkünse çalışma yaptığımız sayfayı tek sayfaya aktarsak .yani detaylarda toplamların olduğu tabloda tek sayfada olsa..çalışma sayfası birebir aktarılsa..elinize sağlık

 

[Orion1]

elinize sağlık istediğim gibi olmuş.sadece şunu da istesem sizden..aktarım 2 farklı sayfaya yapılmış..eğer mümkünse çalışma yaptığımız sayfayı tek sayfaya aktarsak .yani detaylarda toplamların olduğu tabloda tek sayfada olsa..çalışma sayfası birebir aktarılsa..elinize sağlık

Dosyayı güncelledim.
4 numaralı mesajdan indirebilirsiniz.

 

[Orion1]

Bir yerde hata vardı düzelttim.Dosyayı 4ncü mesajdan indirebilirsiniz.

 

[baygal]

çok teşekkür ederim..elinize sağlık

 

[Orion1]

çok teşekkür ederim..elinize sağlık

Rica ederim.
İyi çalışmalar.