Çift Sayfada Gruplama

[Ramocino]

Üstatlar aşağı şekilde kodu var bunu nasıl kısaltabilirim?

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim block1 As Range
Dim block2 As Range
Worksheets("AKADEMIK").Cells.ClearOutline
Worksheets("IDARI").Cells.ClearOutline
Set block1 = Sheets("AKADEMIK").Range("b5:b300")
Set block2 = Sheets("IDARI").Range("b5:b300")
For Each c In block1
    If Left(c.Value, 1) = " " Then
        c.EntireRow.Group
    End If
Next c
For Each c In block1
    If Left(c.Value, 2) = "  " Then
        c.EntireRow.Group
    End If
Next c
For Each c In block2
    If Left(c.Value, 1) = " " Then
        c.EntireRow.Group
    End If
Next c
For Each c In block2
    If Left(c.Value, 2) = "  " Then
        c.EntireRow.Group
    End If
Next c

Worksheets("AKADEMIK").Outline.ShowLevels RowLevels:=1
Worksheets("IDARI").Outline.ShowLevels RowLevels:=1
End Sub

 

[Ömer]

Merhaba,

Kodlar üzerinden değilde, örnek dosya ekleyip yapmak istediğinizi açıklar mısınız.

 

[dost]

Merhaba,

Ben kontrol etmedim. Denersiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Dim i, j As Integer
Dim block1 As Range
Dim block2 As Range
Dim myArr As Variant
Dim mYText As String

Worksheets("AKADEMIK").Cells.ClearOutline
Worksheets("IDARI").Cells.ClearOutline
Set block1 = Sheets("AKADEMIK").Range("b5:b300")
Set block2 = Sheets("IDARI").Range("b5:b300")

myArr = Array(block1, block2)

For i = LBound(myArr) To UBound(myArr)
    For Each c In myArr(i)
        For j = 1 To 2
            mYText = IIf(j = 1, " ", "  ")
            If Left(c.Value, j) = mYText Then c.EntireRow.Group
        Next j
    Next c
Next i

Worksheets("AKADEMIK").Outline.ShowLevels RowLevels:=1
Worksheets("IDARI").Outline.ShowLevels RowLevels:=1

End Sub

 

[Ramocino]

Üstad dosya ektedir.

 

[Ramocino]

DOST DOST DİYE NİCESİNE SARILDIM
...

Teşekkür ederim. Elinize sağlık.