Sayfa başları ve kodları belli bir dosyayı sayfalara ayırmak

[Mesafe]

İlişikte örnek bir bölümü bulunan PDF den convert edilmiş excel dosyamı A sütünunda yer alan değişik kodlara göre (her kod için ayrı sayfa) sayfalara ayırmak için koda ihtiyacım var.

 

[Mesafe]

Hocalarım bir bakarsanız çok sevinirim, önemli ve acil bir konu.
Şimdiden teşekkürler.

 

[hamitcan]

Bu şekilde, bir deneyin.

Sub Aktar()
Dim arr()
    For i = 1 To 150
        If Cells(i, 1) = 561 Then
            x = x + 1
            ReDim Preserve arr(1 To x)
            arr(x) = i
        End If
    Next
    For k = 1 To Sheets.Count
    If Sheets(k).Name <> "Sayfa1" Then Sheets(k).Cells.Clear
    Next

For j = 1 To UBound(arr)
    If UBound(arr) = j Then son = Sayfa1.[a65536].End(3).Row Else son = arr(j + 1)
    If Not Sayfa1.Range("a" & arr(j) & ":" & "a" & son).Find("MUN*") Is Nothing Then
         Set a = Sayfa1.Range("a" & arr(j) & ":" & "a" & son).Find("MUN*")
         S = Sayfa1.Cells(a.Row, 1)
         If SheetExist(Trim(S)) = False Then
            Sheets.Add: ActiveSheet.Name = S
            son1 = [a65536].End(3).Row
            Sayfa1.Range("a" & arr(j) & ":" & "h" & son - 1).Copy Cells(son1 + 1, 1)
         Else
            son2 = Sheets(Trim(S)).[a65536].End(3).Row + 1
            Sayfa1.Range("a" & arr(j) & ":" & "h" & son - 1).Copy Sheets(Trim(S)).Cells(son2 + 1, 1)
         End If
    End If
Next
End Sub
Function SheetExist(ShName As String) As Boolean
    On Error Resume Next
    Application.ScreenUpdating = False
    SheetExist = IIf(Sheets(ShName).Select, True, False)
    Application.ScreenUpdating = True
End Function

 

[Mesafe]

Hocam emekleriniz için ne kadar teşekkür etsem azdır, sağolun varolun.