Calisma sayfalarina ayirma

[ubay06]

Merhaba

Ornek dosyada A sutunundaki verileri gruplayip ayri ayri excel dosyalari seklinde ayırmak istiyorum yardimlarinizi rica ederim.

http://s3.dosya.tc/server11/y9qwda/ORNEK.xlsx.html

 

[PLİNT]

Merhaba
Ornek dosyada A sutunundaki verileri gruplayip ayri ayri excel dosyalari seklinde ayırmak istiyorum yardimlarinizi rica ederim.

Merhaba
Aşağıdaki gibi deneyiniz.
http://s3.dosya.tc/server11/uc894r/ornek.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
Set s1 = ThisWorkbook.Sheets(1)
a = Cells(Rows.Count, 1).End(xlUp).Row
Range("A2:X" & a).Sort Key1:=Cells(1, 1), Order1:=xlAscending
Application.ScreenUpdating = False
For b = 2 To a
    Rows("1:1").Copy
Workbooks.Add
With ActiveWorkbook.Sheets(1)
.Range("A1").PasteSpecial
c = WorksheetFunction.CountIf(Range("A" & b & ":A" & a), Cells(b, 1))
s1.Range("A" & b & ":X" & b + c - 1).Copy
.Range("A2").PasteSpecial
End With
 ChDir ThisWorkbook.Path
kayıt = CreateObject("wscript.Shell").SpecialFolders.Item(ThisWorkbook.Path) & _
Cells(b, 1).Value & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=kayıt
    ActiveWorkbook.Close
b = b + c - 1
Next
Application.ScreenUpdating = True
MsgBox "Bitti"
End Sub
 [/SIZE]