sayfalarının özeti alınan sayfaya bağzı sayfaların aktarılamısın

[taseraydin]

Değerli arkadaşlar bir cari hesap dosyamda standart şekilde açılmış hesap sayfalarının Özetini (MİZAN) makro tuşu ile aldırıyorum fakat özet listede cari hesap işlemi olmayan sayfaların isminide sıralıyor oysa sadece cari hasep sayfaları görünmesi gerekir bu konuda yardımcı olurmusunuz... Saygılar

mizan aktarma için kullandığım makro aşağıdaki gibidir

Sub MİZAN()
Application.ScreenUpdating = False
Set SM = Sheets("MİZAN")
SM.[A6:F65536].Clear
For X = 1 To Worksheets.Count - 1
[A65536].End(3).Select
If ActiveCell.Address = "$A$5" Then
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = 1
Else
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1
End If
SM.Select
ActiveCell.Offset(0, 1) = Sheets(X).Name
ActiveCell.Offset(0, 2) = Sheets(X).[F3]
ActiveCell.Offset(0, 3) = Sheets(X).[F2]
If ActiveCell.Offset(0, 2) > ActiveCell.Offset(0, 3) Then
ActiveCell.Offset(0, 4) = (ActiveCell.Offset(0, 2) - ActiveCell.Offset(0, 3))
ActiveCell.Offset(0, 4).Font.Bold = True
ActiveCell.Offset(0, 5) = ""
End If
If ActiveCell.Offset(0, 3) > ActiveCell.Offset(0, 2) Then
ActiveCell.Offset(0, 5) = (ActiveCell.Offset(0, 3) - ActiveCell.Offset(0, 2))
ActiveCell.Offset(0, 5).Font.Bold = True
ActiveCell.Offset(0, 4) = ""
End If
Next
[C6:F65536].NumberFormat = "#,##0.00"
[B6:F65536].Sort Key1:=[B6], Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
[A5:F5].Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
[B3].Select
Application.ScreenUpdating = True
MsgBox "MİZAN BAŞARIYLA OLUŞTURULMUŞTUR...", vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Lütfen örnek dosya eklermisiniz.

 

[taseraydin]

ilginize teşekkür ederim dosya ekte

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Eğer aktarılacak sayfada F4 hücresi boş veya 0 ise MİZAN sayfasında boş satır olarak gözükmeyecektir. Sadece bakiye verenler MİZAN sayfasına aktarılacaktır.

Sub MİZAN()
    Application.ScreenUpdating = False
    Set SM = Sheets("MİZAN")
    SM.[A6:F65536].Clear
    For X = 2 To Worksheets.Count - 1
    [A65536].End(3).Select
    If Sheets(X).[F4] = "" Or Sheets(X).[F4] = 0 Then GoTo Devam
    If ActiveCell.Address = "$A$5" Then
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = 1
    Else
    ActiveCell.Offset(1, 0).Select
    ActiveCell.Value = ActiveCell.Offset(-1, 0).Value + 1
    End If
    SM.Select
    ActiveCell.Offset(0, 1) = Sheets(X).Name
    ActiveCell.Offset(0, 2) = Sheets(X).[F3]
    ActiveCell.Offset(0, 3) = Sheets(X).[F2]
    If ActiveCell.Offset(0, 2) > ActiveCell.Offset(0, 3) Then
    ActiveCell.Offset(0, 4) = (ActiveCell.Offset(0, 2) - ActiveCell.Offset(0, 3))
    ActiveCell.Offset(0, 4).Font.Bold = True
    ActiveCell.Offset(0, 5) = ""
    End If
    If ActiveCell.Offset(0, 3) > ActiveCell.Offset(0, 2) Then
    ActiveCell.Offset(0, 5) = (ActiveCell.Offset(0, 3) - ActiveCell.Offset(0, 2))
    ActiveCell.Offset(0, 5).Font.Bold = True
    ActiveCell.Offset(0, 4) = ""
    End If
Devam:
    Next
    [C6:F65536].NumberFormat = "#,##0.00"
    [B6:F65536].Sort Key1:=[B6], Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    [A5:F5].Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    [A1].Select
    Application.ScreenUpdating = True
    MsgBox "MİZAN BAŞARIYLA OLUŞTURULMUŞTUR...", vbInformation
End Sub

 

[taseraydin]

teşekür ederim

Değerli
Cost Control problemim haloldu Bilgilerini paylaştığın için teşekür ederim.
Saygılar