Yarım kalan excell çalışmam

[emre_by]

Merhabalar,

Kullanmak istediğim excell çalışmam için yardımınıza ihtiyacım var.Kısaca anlatmam gerekirse

Stok ve kesilmiş faturaların takibini yapmak için

Faturam excell dosyasında fatura kaydı bölümüne manuel girdiğim fatura bilgilerinin fatura bölümünde '' Fatura Kaydet'' Butonu eklenmesini ve bu butona basılması ile
fatura kaydının stok kaydı sayfasında kesilen faturalar bölümüne işlenmesini rica ediyorum.

 

[YUSUF44]

Aşağıdaki makro 5 satırlık fatura için istediğinizi yapar. Ancak açıklamada 200 satır olabileceğini belirtmişsiniz. Bunun son satırının nasıl belirleneceğini belirtirseniz kodda güncelleme yapmaya çalışırım:

Sub fatura()
Set s1 = Sheets("FATURA")
Set s2 = Sheets("STOK KAYDI")
If s1.[B5] = "" Then
    MsgBox "Kaydedilecek müşteri adı bulunmuyor!", vbCritical
    s1.Activate
    s1.[B5].Select
    Exit Sub
ElseIf WorksheetFunction.CountBlank(s1.[B11:B15]) = 5 Then
    MsgBox "Kaydedilecek stok bulunmuyor!", vbCritical
    s1.Activate
    s1.[B11].Select
    Exit Sub
Else
    For stok = 11 To 15
        If s1.Cells(stok, "B") <> "" Then
            yeni = s2.Cells(Rows.Count, "J").End(3).Row + 1
            s2.Cells(yeni, "J") = s1.Cells(stok, "B")
            s2.Cells(yeni, "K") = s1.Cells(stok, "I")
            s2.Cells(yeni, "L") = s1.[L21]
            s2.Cells(yeni, "M") = s1.[L22]
            s2.Cells(yeni, "N") = s1.[L23]
            s2.Cells(yeni, "O") = s1.[L4]
            s2.Cells(yeni, "P") = s1.[B5]
            s2.Cells(yeni, "Q") = s1.Cells(stok, "C")
        End If
    Next
End If
            
End Sub

 

[emre_by]

Yardımınız için teşekkür ederim.Fonksiyon güzel kullanılıyor yalnız bir iki konuda düzenleme yaparsanız memnun olurum.


Stok kaydı sayfasında kesilen faturaların kayıtları en üsten ( J3 )başlayarak aşağı doğru 200 adet kaydetmeli.

Fatura sayfasında eklediğim FATURA KAYDET BUTONUNA fonksiyon tanımlayabilir misiniz? Yaptığınız fonksiyon butona bastığımda çalışsın.

 

[YUSUF44]

O butona sağ tıklayıp makro ata derseniz ve çıkan listede Fatura makrosunu seçerseniz, düğmeye bastığınızda makro çalışır.

200 satır konusunu ilk cevabımda belirttiğim gibi anlamadım. Her zaman 200 satıra bakarsa örnek dosyanızdan gibi az sayır olduğunda alttaki toplam vs satırları da ayrı atılmış gibi aktarır.

Faturanın son stok satırı nerden anlaşılacak?

 

[emre_by]

Teşekkür ederim Yusuf bey
Gönderdiğiniz excell dosyası ile 200 satıra gerek kalmadı.Halledilmiş oldu.

Yalnız proğramı denerken başka bir komutta eksiklik olduğunun farkına vardım.Excell dosyasında durumu anlatmaya çalıştım.İlginiz için tekrar teşekkürler.

 

[YUSUF44]

Bu farklı bir dosya galiba. Bu dosyaya ve isteğinize göre aşağıdaki makroyu deneyiniz:

Sub stok_aktar()

Set s1 = Sheets("SATILANLAR")
sonsat = s1.Cells(Rows.Count, "A").End(3).Row

For sat = 2 To sonsat
    durum = "yok"
    For bolum = 1 To Sheets.Count
        If Sheets(bolum).Name <> s1.Name Then
            sonstok = Sheets(bolum).Cells(Rows.Count, "A").End(3).Row
            If WorksheetFunction.CountIf(Sheets(bolum).Range("A1:A" & sonstok), s1.Cells(sat, "A")) > 0 Then
                yeni = Sheets(bolum).Cells(Rows.Count, "J").End(3).Row + 1
                s1.Range("A" & sat & ":C" & sat).Copy Sheets(bolum).Cells(yeni, "J")
                s1.Range("F" & sat & ":H" & sat).Copy Sheets(bolum).Cells(yeni, "M")
                durum = "var"
                s1.Range("A" & sat & ":H" & sat).Interior.Color = xlNone
                bolum = Sheets.Count
            End If
        End If
    Next
    If durum = "yok" Then
        s1.Range("A" & sat & ":H" & sat).Interior.Color = vbRed
        hata = "evet"
    End If
Next

s1.Activate

If hata = "evet" Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bölümlerde bulunmayan satışlar kırmızıya boyandı!", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Tüm satışlar ilgili bölümlere aktarıldı.", vbInformation
End If

End Sub

 

[emre_by]

Aynı dosya hocam. Daha doğru anlatacağımı düşündüğüm için veri adlarını düzenledim biraz. Proğram güzel çalışıyor, emeğiniz için çok saolun. Allah sizden razı olsun.

 

[emre_by]

Hocam satılanlar sayfasının devamına veri eklediğimde, bölümler önceki girilen değerleri tekrar üzerine ekliyor.Satılanlar sayfasının tümünü bir kerede aktaracak şekilde makroyu düzenleyebilir misiniz?

 

[YUSUF44]

Aşağıdaki makroyu deneyin. Daha önce aktarılmamış olanları aktarır ve I sütununa "Aktarıldı" yazar:

Sub stok_aktar()
Set s1 = Sheets("SATILANLAR")
sonsat = s1.Cells(Rows.Count, "A").End(3).Row
If WorksheetFunction.CountIf(s1.Range("I2:I" & sonsat), "<>" & "Aktarıldı") = 0 Then
    MsgBox "SATILANLAR sayfasında ilgili bölüme aktarılmamış satış bulunmamaktadır!", vbInformation
    GoTo 10
End If
    
For sat = 2 To sonsat
    If s1.Cells(sat, "I") <> "Aktarıldı" Then
        durum = "yok"
        For bolum = 1 To Sheets.Count
            If Sheets(bolum).Name <> s1.Name Then
                sonstok = Sheets(bolum).Cells(Rows.Count, "A").End(3).Row
                If WorksheetFunction.CountIf(Sheets(bolum).Range("A1:A" & sonstok), s1.Cells(sat, "A")) > 0 Then
                    yeni = Sheets(bolum).Cells(Rows.Count, "J").End(3).Row + 1
                    s1.Range("A" & sat & ":C" & sat).Copy Sheets(bolum).Cells(yeni, "J")
                    s1.Range("F" & sat & ":H" & sat).Copy Sheets(bolum).Cells(yeni, "M")
                    durum = "var"
                    s1.Range("A" & sat & ":H" & sat).Interior.Color = xlNone
                    s1.Cells(sat, "I") = "Aktarıldı"
                    bolum = Sheets.Count
                End If
            End If
        Next
        If durum = "yok" Then
            s1.Range("A" & sat & ":H" & sat).Interior.Color = vbRed
            hata = "evet"
        End If
    End If
Next
If hata = "evet" Then
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Bölümlerde bulunmayan satışlar kırmızıya boyandı!", vbCritical
Else
    MsgBox "İşlem tamamlandı." & Chr(10) & Chr(10) & "Tüm satışlar ilgili bölümlere aktarıldı.", vbInformation
End If

10:
s1.Activate
Application.CutCopyMode = False
s1.Cells(sonsat + 1, "A").Select

End Sub

 

[emre_by]

Denedim ve çok güzel çalışıyor.Çok sağolun hocam