sayfa1 dekileri rapor sayfasına alma

[orhankilerci]

sn.cost control ilginize çok teşekkür ederim.son gönderdiğiniz örnek bendede hata vermedi..sayfa 2 de bağzılarında gerçektede kod olmuyor..dediğiniz gibi toplama hatası veriyor..
saygılar.

 

[orhankilerci]

aynı özelliklere sahip girişlerde kod olmasına rağmen sadece birisinin ağırlığını veriyor ..toplamıyor.
saygılar.

 

[Korhan Ayhan]

Selamlar,

En son mesajımdaki dosyayı güncelledim kontrol edermisiniz. Daha önce eklediğim dosyada adet kısımlarını toplatmayı atlamışım. Güncel dosyada bu hatada düzeltilmiştir. İşlemi döngü ile yaptığımdan biraz yavaş çalışabilir. Umarım son hali ile faydası olur.

 

[orhankilerci]

"worksheet sınıfının showAllData yöntemi başarısız " hatasını verdi hata alanı
S3.ShowAllData
ilginiz için çok teşekkür ederim..

 

[Korhan Ayhan]

Selamlar,

Kodu aşağıdaki şekilde değiştirip denermisiniz.

Sub AKTAR()
    On Error Resume Next
    Application.ScreenUpdating = False
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set S3 = Sheets("Sayfa3")
    TARİH = CDate(S1.[G3])
    S1.[B7:G65536].Clear
    S3.Cells.Delete
    SAY = WorksheetFunction.CountIf(S2.[A6:A65536], TARİH)
    If SAY = 0 Then GoTo Son
    S2.[A4].AutoFilter Field:=1, Criteria1:=TARİH
    S2.Range("G4:G" & S2.[A65536].End(3).Row).Copy S3.[A1]
    S2.Range("I4:I" & S2.[A65536].End(3).Row).Copy S3.[B1]
    S2.Range("D4:D" & S2.[A65536].End(3).Row).Copy S3.[C1]
    S2.Range("F4:F" & S2.[A65536].End(3).Row).Copy S3.[D1]
    S2.Range("E4:E" & S2.[A65536].End(3).Row).Copy S3.[E1]
    S2.Range("J4:J" & S2.[A65536].End(3).Row).Copy S3.[F1]
    S3.[A1:C65536].AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    S3.Range("A2:A" & S3.[A65536].End(3).Row).Copy S1.[B7]
    S3.Range("B2:B" & S3.[A65536].End(3).Row).Copy S1.[C7]
    S3.Range("C2:C" & S3.[A65536].End(3).Row).Copy S1.[D7]
    S3.Range("D2:D" & S3.[A65536].End(3).Row).Copy S1.[E7]
    S3.Range("E2:E" & S3.[A65536].End(3).Row).Copy S1.[F7]
    S3.Range("F2:F" & S3.[A65536].End(3).Row).Copy S1.[G7]
    S3.ShowAllData
    S1.Columns("B:G").HorizontalAlignment = xlCenter
    S1.[B7:G65536].Sort Key1:=S1.[B7], Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers
    [A1].Select
    S2.[A4].AutoFilter
    SON_SATIR = S3.[A65536].End(3).Row
    For X = 7 To S1.[B65536].End(3).Row
    TOPLAM_ADET = 0
    TOPLAM_AĞIRLIK = 0
    For Y = 2 To SON_SATIR
    If S1.Cells(X, 2) = S3.Cells(Y, 1) And S1.Cells(X, 3) = S3.Cells(Y, 2) And S1.Cells(X, 4) = S3.Cells(Y, 3) And S1.Cells(X, 7) = S3.Cells(Y, 6) Then
    TOPLAM_ADET = TOPLAM_ADET + S3.Cells(Y, 4)
    TOPLAM_AĞIRLIK = TOPLAM_AĞIRLIK + S3.Cells(Y, 5)
    S1.Cells(X, 5) = TOPLAM_ADET
    S1.Cells(X, 6) = TOPLAM_AĞIRLIK
    End If: Next: Next
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Application.ScreenUpdating = True
    MsgBox "VERİLER BAŞARIYLA AKTARILMIŞTIR.", vbInformation
    Exit Sub
Son:
    MsgBox "VERDİĞİNİZ TARİHE AİT VERİ BULUNAMAMIŞTIR.", vbExclamation
End Sub

 

[orhankilerci]

sn.cost contol ilginize ve emeğinize çok çok teşekkür ederim.
iyi çalışmalar..saygılar..