Soru Hesap Koduna göre yeni sayfa açıp kayıt etme?

mars2 · Salı saat 18:19'de

İyi Günler;
Muhasebe kaydı için daha önceden hazırladığım ve geliştirmeye çalıştığım formun A sutunu veya B sutunundaki hesap kodu yazdığımda;
1- bu koda göre sayfa açılmamış ise sayfa açıyor, ancak, açılan sayfanın B1 hücresine hesap kodu, B2 hücresine hesap adını yazdırmak, 5. satırdan itibaren kayıt yaptırmak
2- hesap kodu ile açılan sayfanın A4 sutununda Sıra No, B4 sutununda tarih, C4 sutununda açıklama, D4 sutunda ise borçlu tutar, E4 sutunda ise alacak tutarı yazısı bulunmaktadır. 5. satırdan itibaren aylardaki hesap kodlarına göre yapılan kayıtları aktarmnak istiyorum.
3- Aşağıdaki makro ile daha önceden kod sayfasına A sutununa Sıra No sutunu ekmeden önce yapmakta idi ancak, A sutuna Sıra No ekleyince ve makroda düzeltmeye çalışmama rağmen kayıt etmemektedir. sorunun kaynağı nerededir ve nasıl çözebiliriz.
4- Ayrıca, her ay kayıtlardan sonra bir seferde aktarmak için makroda ne gi ibi değişiklik yapmak gereklidir.

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.[A4] = "Sıra"
ActiveSheet.[B4] = "Tarih"
ActiveSheet.[C4] = "İzahat"
ActiveSheet.[D4] = "Borç TL"
ActiveSheet.[E4] = "Alacak TL"

ActiveSheet.[A4:E4].Borders.LineStyle = xlContinuous
ActiveSheet.[A4:E4].Font.Bold = True
ActiveSheet.[A4:E4].HorizontalAlignment = xlCenter
ActiveSheet.[A4:E4].VerticalAlignment = xlCenter
End If
Sheets(dönem).Activate
10:
If Intersect(Target, Range("F5: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" 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.[A4] = "Sıra No"
ActiveSheet.[B4] = "Tarih"
ActiveSheet.[C4] = "İzahat"
ActiveSheet.[D4] = "Borç TL"
ActiveSheet.[E4] = "Alacak TL"

ActiveSheet.[A4:E4].Borders.LineStyle = xlContinuous
ActiveSheet.[A4:E4].Font.Bold = True
ActiveSheet.[A4:E4].HorizontalAlignment = xlCenter
ActiveSheet.[A4:E4].VerticalAlignment = xlCenter

ActiveSheet.[B5] = Cells(a, "D")
ActiveSheet.[C5] = Cells(a, "E")
ActiveSheet.[D5] = Cells(a, "F")
ActiveSheet.[E5] = Cells(a, "G")
ActiveSheet.[D2: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") = Date
'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, "B") = Cells(a, "C")
'Sheets(i).Cells(yeni, "C") = Cells(a, "E")
'Sheets(i).Cells(yeni, "D") = Cells(a, "F")

Sheets(i).Cells(yeni, "D").NumberFormat = "#,##0.00 $"
Sheets(i).Cells(yeni, "E").NumberFormat = "#,##0.00 $"
Sheets(i).Range("A" & yeni & ":G" & 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, "A") = Date
'Sheets(i).Cells(yeni, "A").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, "D").NumberFormat = "#,##0.00 $"
Sheets(i).Cells(yeni, "E").NumberFormat = "#,##0.00 $"
Sheets(i).Range("A" & yeni & ":G" & yeni).Borders.LineStyle = xlContinuous
End If
End If
Next
End If

Sheets(dönem).Activate
End Sub

pitchoute · Salı saat 20:31'de

Merhaba, deneyip sonucu paylaşabilir misiniz;

Kod:

' Bu kodu çalışma sayfanızın kod penceresine yerleştirin
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    
    Dim son As Long
    Dim sayfalar As Integer
    Dim dönem As String
    Dim a As Long
    Dim kodVar As Boolean
    Dim i As Integer
    Dim yeni As Long
    Dim hesapKodu As String
    Dim sht As Worksheet
    
    Application.EnableEvents = False
    
    son = WorksheetFunction.Max(Cells(Rows.Count, "B").End(xlUp).Row, Cells(Rows.Count, "C").End(xlUp).Row) + 1
    sayfalar = ThisWorkbook.Sheets.Count
    dönem = Me.Name
    a = Target.Row
    If Not Intersect(Target, Range("B5:C" & son)) Is Nothing Then
        If Not IsEmpty(Cells(a, "B")) Then
            hesapKodu = Cells(a, "B").Value
        ElseIf Not IsEmpty(Cells(a, "C")) Then
            hesapKodu = Cells(a, "C").Value
        Else
            GoTo SkipProcessing
        End If
        kodVar = False
        For Each sht In ThisWorkbook.Worksheets
            If sht.Name = hesapKodu Then
                kodVar = True
                Exit For
            End If
        Next sht
        If Not kodVar Then
            Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            sht.Name = hesapKodu
            sht.Range("A4") = "Sıra No"
            sht.Range("B4") = "Tarih"
            sht.Range("C4") = "İzahat"
            sht.Range("D4") = "Borç TL"
            sht.Range("E4") = "Alacak TL"
            With sht.Range("A4:E4")
                .Borders.LineStyle = xlContinuous
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            sht.Range("B1").Value = hesapKodu
            sht.Range("B2").Value = "Hesap Adı" ' Buraya hesap adını ekleyebilirsiniz
        Else
            Set sht = ThisWorkbook.Sheets(hesapKodu)
        End If
        yeni = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
        sht.Cells(yeni, "A").Value = yeni - 4 ' Sıra No
        sht.Cells(yeni, "B").Value = Cells(a, "D").Value ' Tarih
        sht.Cells(yeni, "C").Value = Cells(a, "E").Value ' İzahat
        sht.Cells(yeni, "D").Value = Cells(a, "F").Value ' Borç TL
        sht.Cells(yeni, "E").Value = Cells(a, "G").Value ' Alacak TL
        sht.Cells(yeni, "D").NumberFormat = "#,##0.00 $"
        sht.Cells(yeni, "E").NumberFormat = "#,##0.00 $"
        sht.Range("A" & yeni & ":E" & yeni).Borders.LineStyle = xlContinuous
    End If
    
SkipProcessing:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "Bir hata oluştu: " & Err.Description, vbCritical
    Application.EnableEvents = True
End Sub

Kayıtları tek seferde aktarmak için aşağıdaki kodu standart bir modüle ekleyin;

Kod:

Sub AylikKayitlariAktar()
    Dim son As Long
    Dim a As Long
    Dim hesapKodu As String
    Dim kodVar As Boolean
    Dim sht As Worksheet
    Dim i As Long
    Dim anaSayfa As Worksheet
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set anaSayfa = ThisWorkbook.Sheets("AnaSayfa") ' Ana sayfanızın adını yazınız
    son = anaSayfa.Cells(anaSayfa.Rows.Count, "B").End(xlUp).Row
    For a = 5 To son
        If Not IsEmpty(anaSayfa.Cells(a, "B")) Then
            hesapKodu = anaSayfa.Cells(a, "B").Value
        ElseIf Not IsEmpty(anaSayfa.Cells(a, "C")) Then
            hesapKodu = anaSayfa.Cells(a, "C").Value
        Else
            GoTo NextRecord
        End If
        kodVar = False
        For Each sht In ThisWorkbook.Worksheets
            If sht.Name = hesapKodu Then
                kodVar = True
                Exit For
            End If
        Next sht
        If Not kodVar Then
            Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            sht.Name = hesapKodu
            sht.Range("A4") = "Sıra No"
            sht.Range("B4") = "Tarih"
            sht.Range("C4") = "İzahat"
            sht.Range("D4") = "Borç TL"
            sht.Range("E4") = "Alacak TL"
            With sht.Range("A4:E4")
                .Borders.LineStyle = xlContinuous
                .Font.Bold = True
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            sht.Range("B1").Value = hesapKodu
            sht.Range("B2").Value = "Hesap Adı" ' Buraya hesap adını ekleyebilirsiniz
        Else
            Set sht = ThisWorkbook.Sheets(hesapKodu)
        End If
        yeni = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
        sht.Cells(yeni, "A").Value = yeni - 4 ' Sıra No
        sht.Cells(yeni, "B").Value = anaSayfa.Cells(a, "D").Value ' Tarih
        sht.Cells(yeni, "C").Value = anaSayfa.Cells(a, "E").Value ' İzahat
        sht.Cells(yeni, "D").Value = anaSayfa.Cells(a, "F").Value ' Borç TL
        sht.Cells(yeni, "E").Value = anaSayfa.Cells(a, "G").Value ' Alacak TL
        sht.Cells(yeni, "D").NumberFormat = "#,##0.00 $"
        sht.Cells(yeni, "E").NumberFormat = "#,##0.00 $"
        sht.Range("A" & yeni & ":E" & yeni).Borders.LineStyle = xlContinuous
        
NextRecord:
    Next a
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

mars2 · Salı saat 22:36'de

Sayın pitchoute;
İlginiz için teşekkürker; ancak ay sayfasındaki "Alacaklı Hesap Kodu" na ait B sutunda ilgili hücreye hesap kodu yazdığımıda yeni sayfayı kod nosu ile açmaktadır. daha önceden açılan sayfanın alacak kısmına kayıt etmektedir.

Ayrıca,


Hesap Kodu (A1 hücresinde)	255.01 (B1 hücresinde )
Hesap Adı (A2) hücresinde)	Demirbaş Hesabı (B2 hücresinde)

Sizin makro ile aşağıdaki olmaktadır.

Hesap Adı	Demirbaş hesabı
Hesap Kodu

pitchoute · Salı saat 22:47'de

Şöyle deneyin hocam;

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    
    Dim son As Long
    Dim a As Long
    Dim hesapKodu As String
    Dim sht As Worksheet
    Dim yeni As Long
    Dim hesapSutun As Variant
    Dim kodVar As Boolean
    Application.EnableEvents = False
    
    son = Cells(Rows.Count, "B").End(xlUp).Row
    a = Target.Row
    If Not Intersect(Target, Range("D5:G" & son)) Is Nothing Then
        For Each hesapSutun In Array("B", "C")
            hesapKodu = Trim(Cells(a, hesapSutun).Value)
            If hesapKodu <> "" Then
                On Error Resume Next
                Set sht = ThisWorkbook.Sheets(hesapKodu)
                On Error GoTo 0
                If sht Is Nothing Then
                    Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    sht.Name = hesapKodu
                    sht.Range("A4") = "Sıra No"
                    sht.Range("B4") = "Tarih"
                    sht.Range("C4") = "İzahat"
                    sht.Range("D4") = "Borç TL"
                    sht.Range("E4") = "Alacak TL"
                    With sht.Range("A4:E4")
                        .Borders.LineStyle = xlContinuous
                        .Font.Bold = True
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                    sht.Range("B1").Value = hesapKodu
                    sht.Range("B2").Value = "Hesap Adı" ' Buraya hesap adını ekleyebilirsiniz
                End If
                yeni = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
                sht.Cells(yeni, "A").Value = yeni - 4 ' Sıra No
                sht.Cells(yeni, "B").Value = Cells(a, "D").Value ' Tarih
                sht.Cells(yeni, "C").Value = Cells(a, "E").Value ' İzahat
                If hesapSutun = "B" Then ' Borçlu Hesap
                    sht.Cells(yeni, "D").Value = Cells(a, "F").Value ' Borç Tutarı
                    sht.Cells(yeni, "E").Value = 0 ' Alacak Tutarı
                Else ' "C" sütunu, Alacaklı Hesap
                    sht.Cells(yeni, "D").Value = 0 ' Borç Tutarı
                    sht.Cells(yeni, "E").Value = Cells(a, "G").Value ' Alacak Tutarı
                End If
                sht.Cells(yeni, "D").NumberFormat = "#,##0.00 $"
                sht.Cells(yeni, "E").NumberFormat = "#,##0.00 $"
                sht.Range("A" & yeni & ":E" & yeni).Borders.LineStyle = xlContinuous
                Set sht = Nothing ' Değişkeni sıfırla
            End If
        Next hesapSutun
    End If
    
SkipProcessing:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "Bir hata oluştu: " & Err.Description, vbCritical
    Application.EnableEvents = True
End Sub

Kod:

Sub AylikKayitlariAktar()
    Dim son As Long
    Dim a As Long
    Dim hesapKodu As String
    Dim sht As Worksheet
    Dim yeni As Long
    Dim hesapSutun As Variant
    Dim anaSayfa As Worksheet
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Set anaSayfa = ThisWorkbook.ActiveSheet ' Ana sayfanızı doğru şekilde seçin
    son = anaSayfa.Cells(anaSayfa.Rows.Count, "B").End(xlUp).Row
    For a = 5 To son
        For Each hesapSutun In Array("B", "C")
            hesapKodu = Trim(anaSayfa.Cells(a, hesapSutun).Value)
            If hesapKodu <> "" Then
                On Error Resume Next
                Set sht = ThisWorkbook.Sheets(hesapKodu)
                On Error GoTo 0
                If sht Is Nothing Then
                    Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
                    sht.Name = hesapKodu
                    sht.Range("A4") = "Sıra No"
                    sht.Range("B4") = "Tarih"
                    sht.Range("C4") = "İzahat"
                    sht.Range("D4") = "Borç TL"
                    sht.Range("E4") = "Alacak TL"
                    With sht.Range("A4:E4")
                        .Borders.LineStyle = xlContinuous
                        .Font.Bold = True
                        .HorizontalAlignment = xlCenter
                        .VerticalAlignment = xlCenter
                    End With
                    sht.Range("B1").Value = hesapKodu
                    sht.Range("B2").Value = "Hesap Adı" ' Buraya hesap adını ekleyebilirsiniz
                End If
                ' Yeni satıra kayıt ekle
                yeni = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row + 1
                sht.Cells(yeni, "A").Value = yeni - 4 ' Sıra No
                sht.Cells(yeni, "B").Value = anaSayfa.Cells(a, "D").Value ' Tarih
                sht.Cells(yeni, "C").Value = anaSayfa.Cells(a, "E").Value ' İzahat
                If hesapSutun = "B" Then ' Borçlu Hesap
                    sht.Cells(yeni, "D").Value = anaSayfa.Cells(a, "F").Value ' Borç Tutarı
                    sht.Cells(yeni, "E").Value = 0 ' Alacak Tutarı
                Else 
                    sht.Cells(yeni, "D").Value = 0 ' Borç Tutarı
                    sht.Cells(yeni, "E").Value = anaSayfa.Cells(a, "G").Value ' Alacak Tutarı
                End If
                sht.Cells(yeni, "D").NumberFormat = "#,##0.00 $"
                sht.Cells(yeni, "E").NumberFormat = "#,##0.00 $"
                sht.Range("A" & yeni & ":E" & yeni).Borders.LineStyle = xlContinuous
                Set sht = Nothing ' Değişkeni sıfırla
            End If
        Next hesapSutun
    Next a
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

mars2 · Dün 00:27 da

Sayın pitchoute

İlginiz ve yardımınız için teşekkürker; ancak ay sayfasındaki "Alacaklı Hesap Kodu" na ait B sutunda ilgili hücreye hesap kodu yazdığımıda yeni sayfayı kod nosu ile açmaktadır. daha önceden açılan sayfanın alacak kısmına kayıt etmektedir.

Ayrıca,


Hesap Kodu (A1 hücresinde)	255.01 (B1 hücresinde )
Hesap Adı (A2) hücresinde)	Demirbaş Hesabı (B2 hücresinde)

Sizin makro ile aşağıdaki olmaktadır.

Hesap Adı	Demirbaş hesabı
Hesap Kodu

B sutunda hücreye 255.01 kodunu yazdığımda aşağıdaki gibi ayrı sayfa açmaktadır.

Ekli dosyayı görüntüle 254233

mars2 · Dün 00:43 da

Sayın pitchoute;

Tekarardan yardım ve ilginiz için teşekkürler,iş yoğunluğu nedeniyle biraz geç cevap verdiğim için özürümün kabul edileceği umuduyla, 2. verdiğiniz kodu da denemem rağmen aynı sorunlar devam etmekte olduğunu

Konu hakkında küçük hatırlatma yapmak istiyorum.
1- A sutunda bulunan kodla hesap adı ile sayfa açılmakta, B sutununda bulunan aynı kodla ayrı bir hesap açılmaktadır.
A sutunda Borç kodu, B sutunda ise Alacak kodu bulunmaktadır. Bu sutunlardaki kodlar aynı hesaba ait olup ayrı ayrı açılmamsı gerekmektedir. İster B sutununa göre isterse de A sutununa göre açılmış ise bunlar aynı hesap olup yeniden açılmasına gerek bulunmamaktadır.
Amaç açılan hesaplara, borçlu ve alacakların kayıtları aktarmak
2- Açılan sayfaların B1 hücresine hesabın kodu (Örneğin 255.01) B2 hücresine ise C sutununda bulunan hesabın adının yazılması. B1 hücresine hesabın kodu yazılmakta B2 hücresine ise hesabın adı yazılmamaktadı(Örneğin 255.01 ise Demirbaş hesabı gibi)
Yeni sayfa açılırken A1 hücresine sabit olarak "Hesabın kodu" A2 hücresien ise "Hesabın Adı" şeklinde matbu yazı çıkması

mars2 · Dün 21:15 da

İyi Akşamlar;
Konu hakkında yardımlarınız beklenmektedir.

Soru Hesap Koduna göre yeni sayfa açıp kayıt etme?

mars2

Ekli dosyalar

pitchoute

mars2

pitchoute

mars2

mars2

mars2