verilere göre sayfa sayfa ayırma

[majestik_]

benim excel dosyamdaki verileri sayfa sayfa ayırmak mümkünmüdür.
yardımlarınız için şimdiden teşekkur.Requisition(I)
sutunundaki değerlere göre ayırma yapmasını istiyorum

 

[Ömer]

Merhaba,

Module kopyalarak çalıştırınız.

Sub SayfalaraDagit()
Application.ScreenUpdating = False
 
Dim j As Integer, syf As Integer, i As Long, sayfa As String
 
For j = 4 To Worksheets.Count
    Sheets(j).Cells.Delete Shift:=xlUp
Next j
 
For syf = 1 To 3
    With Sheets(syf)
        For i = 2 To .Cells(Rows.Count, "I").End(xlUp).Row
            sayfa = Trim(.Cells(i, "I"))
            If Not varmi(sayfa) Then
                Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sayfa
                .Select
                .Range("A1:J1").Copy Sheets(sayfa).Range("A1")
            End If
 
            .Range("A1:J1").Copy Sheets(sayfa).Range("A1")
            .Range("A" & i & ":J" & i).Copy Sheets(sayfa).Range("A" & _
            Sheets(sayfa).Cells(Rows.Count, "A").End(xlUp).Row + 1)
 
            Sheets(sayfa).Range("A:J").EntireColumn.AutoFit
 
        Next i
    End With
Next syf
 
Application.ScreenUpdating = True
End Sub
 
[COLOR=teal]' ............... Sayfa kontrolu .............................[/COLOR]
 
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

.

 

[majestik_]

Ömer bey ilginiz için teşekkür ederim. yalnız ben kodu çalıştıramadım hata verdi gönderdiğim örnek üzerinde çalıştımı acaba denedinizmi?yada ben nerede hata yapıyorum.

 

[Mahir64]

Ömer bey ilginiz için teşekkür ederim. yalnız ben kodu çalıştıramadım hata verdi gönderdiğim örnek üzerinde çalıştımı acaba denedinizmi?yada ben nerede hata yapıyorum.

Merhaba
Bununla ilgili daha öncede bir çalışma yapılmıştı
http://www.excel.web.tr/f50/girilen-veriye-gore-sayfa-acylmasy-ve-kopyalanmasy-t94897.html
Ömer beyin yazdığı kod çalışmaktadr.Requisition göre sayfalara dağılım yapmaktadır.

 

[majestik_]

bende hata verdi.Function varmi(adi As String) As Boolean yazan kısım sarı renkte neyi yanlış yapıyor olabilirim

 

[Ömer]

Hata aldığınız dosyayı eklermisiniz..

.

 

[majestik_]

istediğiniz dosya ektedir.

 

[Ömer]

Kodun son bölümündeki;

End Function[COLOR=red][B].[/B][/COLOR]

Kırmızı işaretli noktayı siliniz.

.

 

[majestik_]

Ömer Bey,

çok teşekkür ederim ben bu makroyu istediğim excel dosyasında kullanabilecekmiyim?

 

[majestik_]

Ömer Bey,

ben bunu aynı çalışma sayfası içinde değilde farklı bir kloser olusturp onun içine atmasını istesem olabilirliliği varmıdır?daha doğrusu her veriyi ayrı ayrı excel dosyasında başka bir klosörün içine taşıması

 

[Ömer]

Yapılabilir.

Linki inceleyiniz. Aynı konuda dün bir soru çözmüştün. Dosyanıza uyarlayamazsanız oluşturacağınız klasörün ismini ve yolunu belirtirseniz yapmaya çalışırım.

http://www.excel.web.tr/f48/sayfalary-macro-ile-ayry-ayry-excel-dosya-haline-t94949.html

.

 

[majestik_]

Ömer Bey,

yapabileceğimi sanmıyorum.dosyanın ismi MR LİSTESİ olabilir masa üstünde bulunacak klasör

 

[Ömer]

Bu şekilde deneyiniz..

Sub SayfalaraDagit()
Application.ScreenUpdating = False
 
Dim j As Integer, syf As Integer, i As Long, sayfa As String
[COLOR=darkgreen]' ............... Sayfa İçeriklerini Sil .........................[/COLOR]
 
For j = 4 To Worksheets.Count
    Sheets(j).Cells.Delete Shift:=xlUp
Next j
 
[COLOR=darkgreen]' ............... Sayfalara Aktar .............................[/COLOR]
For syf = 1 To 3
    With Sheets(syf)
        For i = 2 To .Cells(Rows.Count, "I").End(xlUp).Row
            sayfa = Trim(.Cells(i, "I"))
            If Not varmi(sayfa) Then
                Sheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = sayfa
                .Select
                .Range("A1:J1").Copy Sheets(sayfa).Range("A1")
            End If
 
            .Range("A1:J1").Copy Sheets(sayfa).Range("A1")
            .Range("A" & i & ":J" & i).Copy Sheets(sayfa).Range("A" & _
            Sheets(sayfa).Cells(Rows.Count, "A").End(xlUp).Row + 1)
 
            Sheets(sayfa).Range("A:J").EntireColumn.AutoFit
 
        Next i
    End With
Next syf
[COLOR=darkgreen]' ............... Klasöre Aktar .............................[/COLOR]
For i = 4 To Worksheets.Count
 
    Sheets(i).Select
    dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("[COLOR=blue]Desktop[/COLOR]") & _
    "\[COLOR=red]MR LİSTESİ[/COLOR]" & Application.PathSeparator & Sheets(i).[I2] & ".xls"
 
    ActiveSheet.Copy
    ActiveWorkbook.SaveAs Filename:=dosya
    ActiveWorkbook.Close
 
Next i
 
Application.ScreenUpdating = True
End Sub
 
[COLOR=darkgreen]' ............... Sayfa kontrolu .............................[/COLOR]
 
Function varmi(adi As String) As Boolean
    On Error Resume Next
    varmi = CBool(Len(Worksheets(adi).Name) > 0)
End Function

.

 

[honestman]

Bende ActiveWorkbook.SaveAs Filename:=dosya hata verdi. Sayfa değil de ayrı dosyalar halinde D:/ altına yapıştırmak istiyorum. Deneme1, deneme2 gibi.