Soru Filtreye Göre Devir İşlemi

[berkem13]

Merhabalar, birden fazla carinin takibini yaptığım excel dosyalarım var. Bu carilerin yılsonunda devrini yapmak istiyorum. Aşağıdaki makro ile bunu sağlayabildim ancak carinin birden fazla plakası var. Excel dosyasını hazırlarken de bakiye kısmını ona özel hazırlamıştım. Plakaya göre filtreleme yapınca o plakanın bakiyesini veriyor. Ben de devir işleminin tek kalemde değil de plaka bazında olmasını istiyorum. Örnek dosyalar ve kullanmış olduğum makro ektedir. Nasıl bir yol izleyebilirim? Şimdiden teşekkür ederim.

Makro:

Sub Makro1()
'
' Makro1 Makro
'

'

    Dim xStrPath As String
    Dim xFileDialog As FileDialog
    Dim xFile As String
    On Error Resume Next
    Set xFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
    xFileDialog.AllowMultiSelect = False
    xFileDialog.Title = "Select a folder [Kutools for Excel]"
    If xFileDialog.Show = -1 Then
        xStrPath = xFileDialog.SelectedItems(1)
    End If
    If xStrPath = "" Then Exit Sub
    xFile = Dir(xStrPath & "\*.xlsx")
    Do While xFile <> ""
        Workbooks.Open xStrPath & "\" & xFile
        xFile = Dir


    Sheets("Detay").Select
    Range("U2").Select
    Selection.Copy
    Range("X2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    
    Application.Goto Reference:="R4C1"
    Range("B4").Select
    Range("b4:b" & Range("b65536").End(xlUp).Row).Select
    Selection.EntireRow.Delete

    Range("A4").Select
    ActiveCell.FormulaR1C1 = "8/3/2022"
    Range("B4").Select
    
    If Worksheets("Detay").Range("X2") < 0 Then
    
    ActiveCell.FormulaR1C1 = "Virman Borçlu"
    Range("O4").Select
    ActiveCell.FormulaR1C1 = "DEVİR"
    Range("P4").Select
    Range("X2").Select
    Selection.Copy
    Range("P4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("X2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    
    Range("P4").Select
    ActiveCell.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False, FormulaVersion:=xlReplaceFormula2
    Cells.Find(What:="-", After:=ActiveCell, LookIn:=xlFormulas2, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
    
    Range("A4").Select
    ActiveWorkbook.Save
    ActiveWindow.Close
    
    Else
    
    
    ActiveCell.FormulaR1C1 = "Virman Alacaklı"
    Range("O4").Select
    ActiveCell.FormulaR1C1 = "DEVİR"
    Range("P4").Select
    Range("X2").Select
    Selection.Copy
    Range("P4").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("X2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("A4").Select
    ActiveWorkbook.Save
    ActiveWindow.Close
    
    End If
    
    Loop
End Sub

 

[berkem13]

Güncel

 

[berkem13]

"Özet" sayfasında bulunan plakaları "Detay" sayfasında boş bir alana kopyaladım. Plakaların yanında ki boş hücreye "ETOPLA(F:F;X4;T:T)-ETOPLA(F:F;X4;S:S)" formülünü uygulayarak plakanın bakiyesini buldum. Bunu da makroya uyarlayarak sorunumu çözüme kavuşturacağım. İlgilenen arkadaşlara teşekkür ederim