Soru Karışık verileri isim isim ayırmak

[serdaronline48]

Arkadaşlar dosya burada bir örnek hazırladım. ben şuankini elle doldurdum. orjinalinde 30 kişi var maksadım sayfa1 e yapıştırdığım karışık verileri yan sekmelerde isim isim tarih sırasıyla atasın düşeyara ile uğraştım beceremedim. Yardımcı olursanız çok memnun olurum.
teşekkürler.

İndir Kitap1

Dosyayı indir Kitap1

dosya.co

 

[Ömer]

Merhaba,

Deneyiniz.

Sub aktar()

    Dim S1 As Worksheet, sat As Long, syf As String, i As Long, sh As Worksheet

    Set S1 = Sheets("Sayfa1")
  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each sh In Worksheets
        If sh.Name <> S1.Name Then
            sh.Delete
        End If
    Next

    For i = 2 To S1.Cells(Rows.Count, "B").End(xlUp).Row
        If S1.Cells(i, "C") <> "" Then
            syf = S1.Cells(i, "C") & " " & S1.Cells(i, "D")
            If Not varmi(syf) Then
                Sheets.Add After:=Sheets(Sheets.Count)
                ActiveSheet.Name = syf
                S1.Range("A1").Resize(1, 10).Copy Range("A1")
            End If
            sat = Sheets(syf).Cells(Rows.Count, "A").End(xlUp).Row + 1
            S1.Cells(i, "A").Resize(1, 10).Copy Sheets(syf).Cells(sat, "A")
            Sheets(syf).Cells.EntireColumn.AutoFit
        End If
    Next i
    
    S1.Select
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub
 
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

İndir Kitap1 Kopya

Dosyayı indir Kitap1 Kopya

dosya.co

.

 

[veyselemre]

Sub SayfalaraAktar()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual


    Dim sh As Worksheet, son&, i, krt$

    Set sh = Sheets("Sayfa1")
    sh.Select
    If sh.FilterMode = True Then sh.AutoFilter = False

    son = Cells(Rows.Count, 1).End(3).Row

    With CreateObject("Scripting.Dictionary")

        For Each i In Sheets
            If i.Name <> "Sayfa1" Then i.Delete
        Next i

        For i = 2 To son
            krt = sh.Cells(i, 3).Text & " " & sh.Cells(i, 4).Text
            If Not .exists(krt) Then
                .Add krt, ""
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = krt
                With sh.Range("$A$1:$J$" & son)
                    .AutoFilter Field:=3, Criteria1:=sh.Cells(i, 3).Text
                    .AutoFilter Field:=4, Criteria1:=sh.Cells(i, 4).Text
                    .SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1")
                    Columns.AutoFit
                    sh.Select
                    .AutoFilter
                End With
            End If
        Next i

    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

 

[serdaronline48]

hocam çok teşekkürler oldu.