Çözüldü Diğer sayfalara dağıtmak

[1903emre34@gmail.com]

Merhaba,

Tayin sütün altındaki bilgiye göre diğer sayfalara aktarılması için nasıl kod oluşturabiliriz,

http://s7.dosya.tc/server10/0l57qc/Kitap1_excelweb.zip.html

 

[Ömer BARAN]

Merhaba.

Diğer isimli sayfa adının sonundaki BOŞLUK karakterini silmeyi unutmayın.
Sayfa1'in kod bölümüne yapıştırıp, çalıştırın.
D sütunundaki metinle aynı adı taşıyan sayfaların hazır olduğunu varsaydım.

Sub SAYFALARA_AKTAR()
Set s1 = Sheets("Sayfa1")
son = s1.Cells(Rows.Count, 1).End(3).Row
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
If s1.AutoFilterMode = True Then s1.AutoFilterMode = False
For sat = 2 To son
    If WorksheetFunction.CountIf(s1.Range("D2:D" & sat), s1.Cells(sat, "D")) = 1 Then
        sayfa = s1.Cells(sat, "D")
        s1.Range("A1:H" & son).AutoFilter Field:=4, Criteria1:=sayfa
        Sheets(sayfa).UsedRange.Clear
        s1.Range("A1:H" & son).Cells.SpecialCells(12).Copy Sheets(sayfa).[A1]
    End If: Next: s1.AutoFilterMode = False
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı."
End Sub