Yalnız Mesajı Göster
Eski 09-02-2018, 12:32  
Ömer BARAN
Uzman
 
Giriş: 08/03/2011
Şehir: ANKARA / İSTANBUL
Mesaj: 10,395
Excel Vers. ve Dili:
Office 2013 TÜRKÇE
Varsayılan

Merhaba.

Ya şöyle olursa diye ilave talebiniz olmayacaksa; mevcut örnek belgenize göre bir öneride bulunmak istedim.

UYARILAR:
►Kod ilgili satırda A sütununaki hücreyi kullanmaktadır. Bu nedenle A sütununu boş bırakın.
►E:I sütunlarındaki değerlerin tümünü silmek için C sütunundaki sayısal veriyi silmeniz yeterli olur.

Aşağıdaki şekilde işlem yaparsanız istediğiniz sonuca ulaşılacaktır.
-- Alt taraftan Sayfa1'in adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin,
-- Açılan VBA ekranında sağdaki boş alana aşağıdaki kod'u yapıştırın.
.
Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 3 Or Target.Column > 10 Then Exit Sub
If Target.Column = 3 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 And Cells(Target.Row, 3) = "" Then
    If Cells(Target.Row, 1) = "X" Then Exit Sub
        Cells(Target.Row, 1) = "X"
    Range(Cells(Target.Row, 5), Cells(Target.Row + 1, 9)) = "": Cells(Target.Row, 1) = "": Exit Sub
ElseIf Target.Column = 3 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 And Cells(Target.Row, 3) < 15 Then
    If Cells(Target.Row, 1) = "X" Then Exit Sub
        Cells(Target.Row, 1) = "X": Range(Cells(Target.Row + 1, 5), Cells(Target.Row + 1, 9)) = ""
    topl = Cells(Target.Row, 3): ustkisibasi = topl / 5
    Range(Cells(Target.Row, 5), Cells(Target.Row, 9)) = ustkisibasi: Cells(Target.Row, 1) = "": Exit Sub
ElseIf Target.Column = 3 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 Then
    If Target >= 15 Then
        Cells(Target.Row, 1) = "X": Range(Cells(Target.Row, 5), Cells(Target.Row, 9)) = 3: artan = Target - 15
        dolu = 5 - WorksheetFunction.CountBlank(Range(Cells(Target.Row, 5), Cells(Target.Row, 9)))
        artankisibasi = artan / dolu: ustkisibasi = 3
            For sut = 5 To 9
                If Cells(Target.Row, sut) > 0 Then Cells(Target.Row + 1, sut) = artankisibasi
            Next
        Cells(Target.Row, 1) = "": Exit Sub
    ElseIf Target < 15 Then
        topl = Cells(Target.Row, "X"): kisibasi = topl / 5
        Range(Cells(Target.Row + 1, 5), Cells(Target.Row + 1, 9)) = ""
        Range(Cells(Target.Row, 5), Cells(Target.Row, 9)) = kisibasi
    End If
ElseIf Target.Column > 4 And Target.Column < 10 And Int((Target.Row - 1) / 4) = (Target.Row - 1) / 4 Then
    If Cells(Target.Row, 1) = "X" Then Exit Sub
        Cells(Target.Row, 1) = "X"
            If Target = "" Then Cells(Target.Row + 1, Target.Column) = ""
        topl = Cells(Target.Row, 3)
            If topl >= 15 Then
                For sut = 5 To 9
                    dolu = 5 - WorksheetFunction.CountBlank(Range(Cells(Target.Row, 5), Cells(Target.Row, 9)))
                    artan = topl - 15: ustkisibasi = 15 / dolu: artankisibasi = artan / dolu
                    If Cells(Target.Row, sut) > 0 Then Cells(Target.Row, sut) = ustkisibasi
                    If Cells(Target.Row, sut) > 0 Then Cells(Target.Row + 1, sut) = artankisibasi
                Next
                Cells(Target.Row, 1) = "": Exit Sub
            End If
End If
End Sub
__________________
.
☾✭ İnadına TÜRKÇE ✭☽

-- Sorunuzu, gerçek belgenizle aynı yapıda ve olması gereken sonuçların elle yazıldığı örnek belge ile destekleyiniz.
-- ALTIN ÜYELİK öneriyorum. / FORUM KURALLARInı mutlaka okuyunuz.
-- ALTIN ÜYE olmayanlar, örnek belgeyi dosya.tc, dosyaupload.com gibi bir siteye yükleyip, belgeye erişim adresini verebilir.
-- Özel mesaj ile soru sormayınız. / Geri bildirimde bulunulmayan cevaplarımı siliyorum.
Ömer BARAN Çevrimdışı   Alıntı Yaparak Cevapla