Muhasabe - Ayrı çalışma kitabına kayıt etme

[mars2]

İyi Günler;
Çalışma kitabımında, aylara ait sayfalar bulunmakta, aylarda gesap kodları, izahat ve alacak ve borç miktarı bulunmakta alacak veya borç jesap kodu yazdığımda hesap kouna ait sayfasına aşağıdaki kod ile yazmakta,

İlgili aya ait olan sayfada alacak ve borç kodunu yazdığımda, klasördeki hesap koduna ait çalışma kitabındaki sayfasına kayıt yapmak (kapalı) istiyorum (bulunmaması halinde yeni çalışma kitabı yaratarak) isterim.

Konu hakkında yardımlarınızı için teşekkürler.

modül
sub yevmiye()
---------------------------
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target = "" Then Exit Sub
son = WorksheetFunction.Max(Cells(Rows.Count, "A").End(3).Row, Cells(Rows.Count, "B").End(3).Row) + 1
sayfalar = Sheets.Count
dönem = ActiveSheet.Name
A = Target.Row
If Intersect(Target, Range("A2:B" & son)) Is Nothing Then GoTo 10
For i = 1 To sayfalar
If Sheets(i).Name & "a" = Target & "a" Then
kod = "Var"
End If
Next
If kod <> "Var" Then
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = Target
ActiveSheet.[A1] = "Sıra No"
ActiveSheet.[B1] = "Tarih"
ActiveSheet.[C1] = "İZahat"
ActiveSheet.[D1] = "Borç TL"
ActiveSheet.[E1] = "Alacak TL"
ActiveSheet.[A1:E1].Borders.LineStyle = xlContinuous
ActiveSheet.[A1:E1].Font.Bold = True
ActiveSheet.[A1:E1].HorizontalAlignment = xlCenter
ActiveSheet.[A1:E1].VerticalAlignment = xlCenter
End If
Sheets(dönem).Activate
10:
If Intersect(Target, Range("F2:G" & son)) Is Nothing Then Exit Sub
If Target.Offset(0, -5) = "" Then
MsgBox "Lütfen önce " & Target.Offset(-(A - 1), -5) & "nu giriniz", vbCritical
Application.EnableEvents = False
Target = ""
Application.EnableEvents = True
Exit Sub
End If

For i = 1 To sayfalar
If Cells(A, "A") <> "" Then
If Sheets(i).Name & "a" = Cells(A, "A") & "a" Then
kod = "Var"
End If
Else
If Sheets(i).Name & "a" = Cells(A, "B") & "a" Then
kod = "Var"
End If
End If
Next

If kod <> "Var" Then
Sheets.Add After:=ActiveSheet
If Cells(A, "A") <> "" Then
ActiveSheet.Name = Cells(A, "A")
Else
ActiveSheet.Name = Cells(A, "B")
End If

ActiveSheet.[A1] = "Sıra No"
ActiveSheet.[B1] = "Tarih"
ActiveSheet.[C1] = "İZahat"
ActiveSheet.[D1] = "Borç TL"
ActiveSheet.[E1] = "Alacak TL"
ActiveSheet.[A1:E2].Borders.LineStyle = xlContinuous
ActiveSheet.[A1:E1].Font.Bold = True
ActiveSheet.[A1:E1].HorizontalAlignment = xlCenter
ActiveSheet.[A1:E1].VerticalAlignment = xlCenter
ActiveSheet.[F2] = Cells(A, "E")
ActiveSheet.[G2] = Cells(A, "F")
ActiveSheet.[C2:E200].NumberFormat = "#,##0.00 $"

Else
For i = 1 To sayfalar
If Cells(A, "A") <> "" Then
If Sheets(i).Name & "a" = Cells(A, "A") & "a" Then
yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
Sheets(i).Cells(yeni, "B").NumberFormat = "dd/mm/yyyy"
Sheets(i).Cells(yeni, "B") = Cells(A, "D")
Sheets(i).Cells(yeni, "C") = Cells(A, "E")
Sheets(i).Cells(yeni, "D") = Cells(A, "F")
Sheets(i).Cells(yeni, "E") = Cells(A, "G")
Sheets(i).Cells(yeni, "F").NumberFormat = "#,##0.00 $"
Sheets(i).Cells(yeni, "G").NumberFormat = "#,##0.00 $"
Sheets(i).Range("A" & yeni & ":E" & yeni).Borders.LineStyle = xlContinuous
End If
Else
If Sheets(i).Name & "a" = Cells(A, "B") & "a" Then
yeni = Sheets(i).Cells(Rows.Count, "A").End(3).Row + 1
Sheets(i).Cells(yeni, "B") = Date
Sheets(i).Cells(yeni, "B").NumberFormat = "dd/mm/yyyy"
Sheets(i).Cells(yeni, "C") = Cells(A, "C")
Sheets(i).Cells(yeni, "D") = Cells(A, "F")
Sheets(i).Cells(yeni, "E") = Cells(A, "G")
Sheets(i).Cells(yeni, "F").NumberFormat = "#,##0.00 $"
Sheets(i).Cells(yeni, "G").NumberFormat = "#,##0.00 $"
Sheets(i).Range("A" & yeni & ":E" & yeni).Borders.LineStyle = xlContinuous
End If
End If
Next
End If

Sheets(dönem).Activate
End Sub

 

[mars2]

İyi Akşamlar;

Klasörün içinde hesap koduna (örneğin 792.1) ait çalışma kitabında bulunması halinde kayıt yapacak, bulunmması halinde ise o kuodda ait çalışma kitabı oluşturacak ve kayıt yapmak istiyorum.

Konu hakkında farklı fikir ve yardımlarınızı beklemekteyim.