Sütundaki verilere göre ayrı dosya olusturma

[ergaruda]

Merhabalar. Excelde bulunan verilerde: ilk sütunda tekrar eden her verinin karşılığı olan diğer hücreleri nasıl ayrı ayrı excel dosyasına ayırabiliriz.

Örneğin

SÜTUNLAR: A B C D E
BAŞLIK : KİŞİ İL MESLEK YAŞ CİNSİYET
aa ANKARA ÖĞRETMEN 35 BAY
aa İZMİR MANAV 24 BAYAN
bb MUĞLA GARSON 32 BAY
bb SİVAS ÖĞRENCİ 19 BAY
cc ADANA KUAFÖR 22 BAYAN
cc ANTALYA ZABITA 44 BAY

KİŞİ SÜTUNUNDA YER ALAN HER ŞAHIS İÇİN AYRI AYRI EXCEL DOSYASI OLUŞTULABİLİR MİYİZ. (öRN:aa İSİMLİ EXCEL DOSYASINDA AYNI BAŞLIKLAR VE aa SATIRINDAKİ VERİLER YER ALACAK. bb VE cc EXCEL DOSYALARI DA KENDİ SATIR KARŞILIĞINDAKİ VERİLER BULUNACAK)

ŞİMDİDEN TEŞEKKÜRLER

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Option Explicit
Sub kod()
Dim a As Long, b As Long, r As Long
Dim alan As Range
Dim isim As String
Dim w1 As Workbook

r = Cells(Rows.Count, "A").End(3).Row
For a = 2 To r
    If WorksheetFunction.CountIf(Range("A1:A" & a), Cells(a, "A")) = 1 Then
        Set alan = Range("A1:E1")
        isim = Cells(a, "A") & ".xlsx"
        For b = a To r
            If Cells(b, "A") = Cells(a, "A") Then
                Set alan = Union(alan, Range("A" & b & ":E" & b))
            End If
        Next
        Application.ScreenUpdating = False
        Set w1 = Workbooks.Add
        alan.Copy w1.Sheets(1).Range("A1")
        w1.SaveAs isim
        w1.Close 0
        Application.ScreenUpdating = True
    End If
Next
MsgBox "İşlem tamam"
End Sub