formülle yapılan işlemleri makro ile yapabilirmiyiz

[Akif59]

Merhaba
mavi alandaki topla çarpım formülünden makro ile kurtulmak mümkünmü
kırmızı alandaki çıkarma formülünden makro ile kurtulmak mümkünmü

 

[Akif59]

.

 

[Akif59]

Merhaba
mavi alandaki topla çarpım formülünden makro ile kurtulmak mümkünmü
kırmızı alandaki çıkarma formülünden makro ile kurtulmak mümkünmü


Ekli dosyayı görüntüle 216714

Merhaba bir çözümü yok mudur

 

[muratboz06]

dosya.tc sitesine yüklerseniz ve linki paylaşırsanız bakabilirim.

 

[Akif59]

dosya.tc sitesine yüklerseniz ve linki paylaşırsanız bakabilirim.

DENEME.xlsx dosyasını indir - download

DENEME.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[muratboz06]

Dosyanızın yedeğini aldıktan sonra deneyiniz.

Sub ToplaveCarp()
    sonSatır = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Dim cell As Range
    ActiveSheet.Range("D15:DI15").Select
    For Each cell In Selection
        sütun = cell.Column
        For i = 18 To sonSatır
            toplam = toplam + Cells(i, sütun) * Cells(i, 114)
        Next i
        cell.Value = toplam
        cell.Offset(1, 0) = cell.Offset(-1, 0) - cell
        toplam = 0
    Next cell
    Cells(14, 4).Select
End Sub

 

[Akif59]

Dosyanızın yedeğini aldıktan sonra deneyiniz.

Sub ToplaveCarp()
    sonSatır = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Dim cell As Range
    ActiveSheet.Range("D15:DI15").Select
    For Each cell In Selection
        sütun = cell.Column
        For i = 18 To sonSatır
            toplam = toplam + Cells(i, sütun) * Cells(i, 114)
        Next i
        cell.Value = toplam
        cell.Offset(1, 0) = cell.Offset(-1, 0) - cell
        toplam = 0
    Next cell
    Cells(14, 4).Select
End Sub

Merhaba murat bey kodun aktif olarak çalışması gerekiyor ben dosyada d18 dı 118 aralıgına degerler girdikce bu gederleri dj18 dj118 aralığındaki değerlere çarpacak
bir arkadaşımız şöyle bir kod yazdı istediğim tam olarak bu fakat bu kodda öyle bir sıkıntı var önece dj18 dj118 aralıgındaki değeri öncelikli girmemi istiyor

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("D18I118")) Is Nothing Then
' On Error Resume Next
' Application.EnableEvents = False
Cells(15, Target.Column) = WorksheetFunction.SumProduct(Range(Cells(18, Target.Column), Cells(118, Target.Column)), Range("DJ18J118"))
Cells(16, Target.Column) = Cells(15, Target.Column) - Cells(14, Target.Column)
Range("DJ15") = WorksheetFunction.Sum(Range("D15I15"))
Range("DJ16") = WorksheetFunction.Sum(Range("D16I16"))
Range("DJ17") = WorksheetFunction.Sum(Range("D17I17"))
' Application.EnableEvents = True
End If
End Sub

 

[muratboz06]

Aşağıdaki kodu sayfanın kod kısmına yazınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D18:DI118")) Is Nothing Then
        Call ToplaveCarp
        Target.Select
    End If
End Sub


Sub ToplaveCarp()
    sonSatır = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Dim cell As Range
    ActiveSheet.Range("D15:DI15").Select
    For Each cell In Selection
        sütun = cell.Column
        For i = 18 To sonSatır
            toplam = toplam + Cells(i, sütun).Value * Cells(i, 114).Value
        Next i
        cell.Value = toplam
        cell.Offset(1, 0) = cell.Offset(-1, 0).Value - cell.Value
        toplam = 0
    Next cell
End Sub

 

[Akif59]

Aşağıdaki kodu sayfanın kod kısmına yazınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D18:DI118")) Is Nothing Then
        Call ToplaveCarp
        Target.Select
    End If
End Sub


Sub ToplaveCarp()
    sonSatır = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Dim cell As Range
    ActiveSheet.Range("D15:DI15").Select
    For Each cell In Selection
        sütun = cell.Column
        For i = 18 To sonSatır
            toplam = toplam + Cells(i, sütun).Value * Cells(i, 114).Value
        Next i
        cell.Value = toplam
        cell.Offset(1, 0) = cell.Offset(-1, 0).Value - cell.Value
        toplam = 0
    Next cell
End Sub

Merhaba murat bey kod hata veriyor hata çözülse bile aynı sayfada aynı başlıklı başka bir kod var
gerçek dosyayı ekliyorum

deneme.xlsm dosyasını indir - download

deneme.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[muratboz06]

68.satırdan dolayı hata veriyor, kodu aşağıdaki ile değiştiriniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D18:DI118")) Is Nothing Then
        Call ToplaveCarp
    End If
End Sub
Sub ToplaveCarp()
    sonSatır = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Dim cell As Range
    ActiveSheet.Range("D15:DI15").Select
    For Each cell In Selection
        sütun = cell.Column
        For i = 18 To 118
        If i = 68 Then
        GoTo DoNothing
        End If
            toplam = toplam + Cells(i, sütun).Value * Cells(i, 114).Value
        Next i
DoNothing:
        cell.Value = toplam
        cell.Offset(1, 0) = cell.Offset(-1, 0).Value - cell.Value
        toplam = 0
    Next cell
End Sub

 

[Akif59]

68.satırdan dolayı hata veriyor, kodu aşağıdaki ile değiştiriniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D18:DI118")) Is Nothing Then
        Call ToplaveCarp
    End If
End Sub
Sub ToplaveCarp()
    sonSatır = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
    Dim cell As Range
    ActiveSheet.Range("D15:DI15").Select
    For Each cell In Selection
        sütun = cell.Column
        For i = 18 To 118
        If i = 68 Then
        GoTo DoNothing
        End If
            toplam = toplam + Cells(i, sütun).Value * Cells(i, 114).Value
        Next i
DoNothing:
        cell.Value = toplam
        cell.Offset(1, 0) = cell.Offset(-1, 0).Value - cell.Value
        toplam = 0
    Next cell
End Sub

Elinize sağlık murat bey çok güzel oldu