Aktar Problemi

[qwertylion]

Merhaba arkadaşlar;
Sitede var olan kodları kendi çapımda dosyama uyarlıyorum .

Ekteki dosyada verileri ilgili sayfalara aktarmaya çalışıyorum ama hep aynı satıra aktarıyor. kodda bir yerde hata yapıyorum ama nerde yaptığımı bulamadım.

Sitede bir sürü aktar kodu var ama ben hatamı bulmaya çalışıyoruum.

Teşekkür ederim

 

[ExcelF1]

Sanırım Siz her ili ayrı sayfalarda görüntülemek istiyorsunuz. Şu şekilde deneyiniz.

Sub akın()
'sayfaları silip o ya mükerrer hariçleri yazdırıyoruz
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "ANA SAYFA" Then ws.Delete
Next
Application.DisplayAlerts = True
Range("o:o").ClearContents
    Columns("B:B").Select
    Selection.Copy
    Columns("O:O").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("O:O").RemoveDuplicates Columns:=1, Header:=xlNo
    
' o yazdırdıklarımıza yeni sayfa açıyoruz
Application.ScreenUpdating = False
Dim STR As Long, SYF As Worksheet
Set SYF = Sheets("ANA SAYFA")
For STR = 3 To SYF.Cells(Rows.Count, "o").End(xlUp).Row
Sheets.Add after:=Sheets(Sheets.Count)
ActiveSheet.Name = SYF.Cells(STR, "o")
Next
Application.ScreenUpdating = True
Sheets("ana sayfa").Select
Range("o:o").ClearContents

'yeni sayfa açtıklarımıza data aktarıyoruz
Dim I, SUT, SON As Long
For I = 2 To Sheets.Count
Sheets(I).[A2:M1000].Clear
For SUT = 1 To Sheets("ANA SAYFA").UsedRange.Rows.Count
If Sheets(I).Name = Cells(SUT, "B") Then
Sheets("ANA SAYFA").Cells(SUT, "A").EntireRow.Copy
Sheets(I).[A65536].End(3).Offset(1, 0).PasteSpecial
End If
Next
Next
Application.CutCopyMode = False

End Sub

 

[qwertylion]

teşekkür ederim 2 saattir çözmeye çalışıyordum
sağolun

 

[ExcelF1]

Rica ederim. Kolay gelsin.