Merhaba görselde anlatma çalıştığım bölme işlemini makro ile yapabilir miyiz

YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Daha önceki sorunuzda da olduğu gibi bu işlemde asıl yapılmak isteneni anlayabileceğimiz şekilde açıklar mısınız? O formüller dosyada yokmuş gibi düşünün.
 
A

Akif59

Altın Üye
Katılım
15 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2013 ve 2016
Altın Üyelik Bitiş Tarihi
20-03-2025
YUSUF44' Alıntı:
Daha önceki sorunuzda da olduğu gibi bu işlemde asıl yapılmak isteneni anlayabileceğimiz şekilde açıklar mısınız? O formüller dosyada yokmuş gibi düşünün.
Genişletmek için tıkla ...
bölen kısmındaki tüm değerleri sildiğimizde sarı alandaki değerler ile aynı değere sahip - degerde kırmızı bir alan var kırmızı alanı sıfırlamak

216217 216218
ilk değerin üzerinden ilerlersek ben sarı alandaki değerler 161 e bölünebilir dedim formül bana evet 4 tane 161 çıkar sonucunu verdi kalan değeri bir alt satırda 21 böl dedim 2 adet 21 çıkardı bu bölümden kalanı da 10 böl dedim 1 adet çıkardı bu bölümden kalanı da 2 böl dedim 3 çıkardı ve kırmızı alandaki eksi değerleri sıfırladım

tabi bölen kısmında benim belirlediğim değerler sarı alandaki tüm değerleri bölüp çıkan sonuçları pembe alandaki ilgili alana yazıyor
mantığı anlamanın en iyi yolu bölen kısmındaki değerleri bir kaç defa büyükten küçüğe değiştirmeniz kırmızı alandaki değişimi göreceksiniz
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,071
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki kodu dener misiniz?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Selection.Count > 1 Then Exit Sub
If Intersect(Target, [AI12:DI12]) Is Nothing Then GoTo 10
Target.Select
Application.ScreenUpdating = False
If Target = "" Then
Columns(Target.Column).EntireColumn.Hidden = True
Else
Columns(Target.Column + 1).EntireColumn.Hidden = False
Columns(Target.Column + 2).EntireColumn.Hidden = False
Columns(Target.Column + 3).EntireColumn.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
10:
If Intersect(Target, [C34:C66, C84:C117]) Is Nothing Then GoTo 20
Target.Select
Application.ScreenUpdating = False
If Target = "" Then
Rows(Target.Row).EntireRow.Hidden = True
Else
Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
20:
If Intersect(Target, [AG12]) Is Nothing Then GoTo 30
Target.Select
Application.ScreenUpdating = False
If Target <> "" Then
Columns(Target.Column + 1).EntireColumn.Hidden = False
Columns(Target.Column + 2).EntireColumn.Hidden = False
Columns(Target.Column + 3).EntireColumn.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
30:
If Intersect(Target, [C33, C83]) Is Nothing Then GoTo 40
Target.Select
Application.ScreenUpdating = False
If Target <> "" Then
Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
40:
If Intersect(Target, [DJ127:DJ131]) Is Nothing Then Exit Sub
a = Target.Row
If Target = "" Then
    Range("D" & a & ":AH" & a).ClearContents
    Exit Sub
End If

If IsNumeric(Target) = True Then
    For k = 4 To 34
        If Cells(122, k) <> "" Then
            If a = 127 Then
                Cells(a, k) = WorksheetFunction.RoundDown(Cells(122, k) / Target, 0)
            ElseIf a = 128 Then
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(127, "DJ"))) / Target, 0)
            ElseIf a = 129 Then
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(128, "DJ") + Cells(a - 2, k) * Cells(127, "DJ"))) / Target, 0)
            ElseIf a = 130 Then
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(129, "DJ") + Cells(a - 2, k) * Cells(128, "DJ") + Cells(a - 3, k) * Cells(127, "DJ"))) / Target, 0)
            Else
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(130, "DJ") + Cells(a - 2, k) * Cells(129, "DJ") + Cells(a - 3, k) * Cells(128, "DJ") + Cells(a - 4, k) * Cells(127, "DJ"))) / Target, 0)
            End If
        Else
            Cells(a, k).ClearContents
        End If
    Next
Else
    Range("D" & a & ":AH" & a).ClearContents
End If
        
End Sub
 
A

Akif59

Altın Üye
Katılım
15 Mart 2020
Mesajlar
66
Excel Vers. ve Dili
2013 ve 2016
Altın Üyelik Bitiş Tarihi
20-03-2025
YUSUF44' Alıntı:
Aşağıdaki kodu dener misiniz?

PHP: 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
If Selection.Count > 1 Then Exit Sub
If Intersect(Target, [AI12:DI12]) Is Nothing Then GoTo 10
Target.Select
Application.ScreenUpdating = False
If Target = "" Then
Columns(Target.Column).EntireColumn.Hidden = True
Else
Columns(Target.Column + 1).EntireColumn.Hidden = False
Columns(Target.Column + 2).EntireColumn.Hidden = False
Columns(Target.Column + 3).EntireColumn.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
10:
If Intersect(Target, [C34:C66, C84:C117]) Is Nothing Then GoTo 20
Target.Select
Application.ScreenUpdating = False
If Target = "" Then
Rows(Target.Row).EntireRow.Hidden = True
Else
Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
20:
If Intersect(Target, [AG12]) Is Nothing Then GoTo 30
Target.Select
Application.ScreenUpdating = False
If Target <> "" Then
Columns(Target.Column + 1).EntireColumn.Hidden = False
Columns(Target.Column + 2).EntireColumn.Hidden = False
Columns(Target.Column + 3).EntireColumn.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
30:
If Intersect(Target, [C33, C83]) Is Nothing Then GoTo 40
Target.Select
Application.ScreenUpdating = False
If Target <> "" Then
Rows(Target.Row + 1 & ":" & Target.Row + 3).EntireRow.Hidden = False
End If
Target.Select
Application.ScreenUpdating = True
40:
If Intersect(Target, [DJ127:DJ131]) Is Nothing Then Exit Sub
a = Target.Row
If Target = "" Then
    Range("D" & a & ":AH" & a).ClearContents
    Exit Sub
End If

If IsNumeric(Target) = True Then
    For k = 4 To 34
        If Cells(122, k) <> "" Then
            If a = 127 Then
                Cells(a, k) = WorksheetFunction.RoundDown(Cells(122, k) / Target, 0)
            ElseIf a = 128 Then
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(127, "DJ"))) / Target, 0)
            ElseIf a = 129 Then
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(128, "DJ") + Cells(a - 2, k) * Cells(127, "DJ"))) / Target, 0)
            ElseIf a = 130 Then
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(129, "DJ") + Cells(a - 2, k) * Cells(128, "DJ") + Cells(a - 3, k) * Cells(127, "DJ"))) / Target, 0)
            Else
                Cells(a, k) = WorksheetFunction.RoundDown((Cells(122, k) - (Cells(a - 1, k) * Cells(130, "DJ") + Cells(a - 2, k) * Cells(129, "DJ") + Cells(a - 3, k) * Cells(128, "DJ") + Cells(a - 4, k) * Cells(127, "DJ"))) / Target, 0)
            End If
        Else
            Cells(a, k).ClearContents
        End If
    Next
Else
    Range("D" & a & ":AH" & a).ClearContents
End If
       
End Sub
Genişletmek için tıkla ...
Merhaba Yusuf bey dünkü kodla aynı sayfanın kod bölümünde çalışmayacağına kadar düşünüp aynı kodun altına devam etmişsiniz süpersiniz ya ne diyebilirim-ki tüm kontrollerimi detaylıca yapıp dönüş yapacağım emeğinize sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst