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

Katılım
29 Mart 2021
Mesajlar
10
Excel Vers. ve Dili
Excel
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.

 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Deneyiniz.
Kod:
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


.
 

Ekli dosyalar

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod:
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
 
Üst