Aktif dosyasındaki makroya Ozet dosyası için ekleme

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Aktif dosyasındaki makroya Ozet dosyasındaki D ve E sütunları için ÇOKEĞERSAY fonksiyonunun görevini üstlenecek eklemeye yardım etmeniz mümkün mü, lütfen?
Saygılarımla

 

[Ömer]

Merhaba

Bu şekilde deneyiniz.

Sub Özetkayıt()
    Dim s1 As Worksheet: Dim sd As Object
    Dim a As Variant: Dim liste As Variant
    Dim i As Long: Dim b()
        Set s1 = Sheets("Sayfa1")
        son = s1.Cells(Rows.Count, 1).End(xlUp).Row
        Set sd = CreateObject("scripting.dictionary")
            a = s1.Range("A1:E" & son)
            ReDim b(1 To UBound(a), 1 To 5)
                For i = 1 To UBound(a)
                    If a(i, 1) <> "" Then
                        liste = a(i, 3)

                        If Not sd.exists(liste) Then
                            k = k + 1
                            sd.Add liste, k
       
                            b(k, 1) = a(i, 2)
                            b(k, 2) = a(i, 3)
                            b(k, 3) = a(i, 5)
                            b(k, 4) = 0
                            b(k, 5) = 0
                        End If
                        If a(i, 4) = "İç" Then
                            b(sd.Item(liste), 4) = b(sd.Item(liste), 4) + 1
                        ElseIf a(i, 4) = "Dış" Then
                            b(sd.Item(liste), 5) = b(sd.Item(liste), 5) + 1
                        End If
                       
                    End If
                Next i
            Workbooks.Open ("C:\Users\Hp\IGC\Desktop\Ozet.xlsx")
        Sheets("Sayfa1").Select
            Range("a1").Select
            Columns("A:E").ClearContents
            Range("A1").Resize(sd.Count, 5) = b
        [D1] = "İç"
        [E1] = "Dış"
End Sub

 

[Tevfik_Kursun]

Sayın Ömer Hocam,
İlginize çok teşekkür ederim.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Ömer Hocam,
Ozet dosyasında E ve D sütunlarındaki değerlerin farkını "Kalan" adı altında F sütununa yazdırabilir miyiz? Ben şöyle bir ekleme yaptım. Daha pratik bir çözüm olabilir. Onu da öğrenirsem makbule geçer.

        [F1] = "Kalan"
        
        Range("F2").Select
        ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
    
        son = ""
        son = Cells(Rows.Count, "A").End(3).Row
        
    Range("F2").Select
    Selection.AutoFill Destination:=Range("F2:F" & son)
    Columns("F:F").EntireColumn.AutoFit
    Range("F2:F" & son).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G2").Select
    Application.CutCopyMode = False

Saygılarımla

 

[Tevfik_Kursun]

Sayın Ömer Hocam,

        [F1] = "Kalan"
        
        son = ""
        son = Cells(Rows.Count, "A").End(3).Row
        
        Range("F2").Select
            If Cells(1 + x, 5) <> "" Then
                For x = 1 To son - 1
                    Cells(1 + x, 6) = Cells(1 + x, 5) - Cells(1 + x, 4)
                Next x
            End If

Eklediğim parçayı bu hale getirdim. Daha farklı olur mu, bilemiyorum?
Saygılarımla

 

[Ömer]

Sorunuzu tam olarak anlayamadım, istediniz bu mu?

Sub Özetkayıt()
    Dim s1 As Worksheet: Dim sd As Object
    Dim a As Variant: Dim liste As Variant
    Dim i As Long: Dim b()
        Set s1 = Sheets("Sayfa1")
        son = s1.Cells(Rows.Count, 1).End(xlUp).Row
        Set sd = CreateObject("scripting.dictionary")
            a = s1.Range("A1:E" & son)
            ReDim b(1 To UBound(a), 1 To 6)
                For i = 1 To UBound(a)
                    If a(i, 1) <> "" Then
                        liste = a(i, 3)

                        If Not sd.exists(liste) Then
                            k = k + 1
                            sd.Add liste, k
     
                            b(k, 1) = a(i, 2)
                            b(k, 2) = a(i, 3)
                            b(k, 3) = a(i, 5)
                            b(k, 4) = 0
                            b(k, 5) = 0
                        End If
                        If a(i, 4) = "İç" Then
                            b(sd.Item(liste), 4) = b(sd.Item(liste), 4) + 1
                        ElseIf a(i, 4) = "Dış" Then
                            b(sd.Item(liste), 5) = b(sd.Item(liste), 5) + 1
                        End If
                        b(sd.Item(liste), 6) = b(sd.Item(liste), 5) - b(sd.Item(liste), 4)
                    End If
                Next i
            Workbooks.Open ("C:\Users\Hp\IGC\Desktop\Ozet.xlsx")
        Sheets("Sayfa1").Select
            Range("a1").Select
            Columns("A:F").ClearContents
            Range("A1").Resize(sd.Count, 6) = b
        [D1] = "İç"
        [E1] = "Dış"
        [F1] = "Kalan"
End Sub

 

[Tevfik_Kursun]

Sayın Ömer Hocam,
Çok teşekkür ederim.
Saygılarımla