Data sayfasını ay adına göre diğer sayfalara aktarma

[cems]

Ekteki dosyada bulunan kodlar Sn Halit3'e ait olup, orijinalinde başka bir dosyaya veri aktarıyor.

Kodlarda , tek bir dosyada bulunan DATA sayfasındaki verilerin satırlarda bulunan ay adını taşıyan sayfaya , tarih sırasına göre taşınması için nasıl bir değişiklik yapılması gerektiği konusunda desteğinizi arıyorum .

DATA sayfasında ikinci sütunda bulunan tarih , (+) ile 3cü sütuna aynen alındı fakat ay adını taşıması için 3cü sütundaki hücreler ( sağ tıklanıp ) biçimlendirilmede tarih özelliğinde MART 01 seçeneği ile elde edildi . DATA sayfasındaki verilerin bu ay kriterine + tarih sırasına göre ilgili sayfalara ayıklanarak atılması gerekli

 

[Ömer]

Merhaba Cem bey,

Amacınız B sütunundaki tarihlere göre ay bazında verileri ilgili sayfalara aktarmak mı? Ayrıca yılın bir önemi olacak mı?

.

 

[cems]

Ömer Bey Merhaba ,
Sizi tekrar görmek çok güzel
Temel amaç B sütunundaki KARIŞIK tarihlere göre verileri ait olduğu sayfaya TARİH SIRASINDA dizebilmek.
Sadece ay adını gösteren sütunu belki çözümde yardımcı olur diye düşünmüştüm ama pasif bir sütun, bundan başka nedeni yoktu. Kodlar tarihe bakıp ilgili AY sayfasına dizerse yeterli . Bir ayrıntı da , bir satır aslında 50 55 hücre bilgisinden oluşuyor yani kopyalayıp yapışacak veri sağa doğru uzun.

Yılın hiçbir önemi yok, bu bir sene her hafta ayıklanacak bir tablo olacak ama geçmiş ya da gelecek yıla geçme yok

 

[Ömer]

Bu şekilde deneyiniz..

Sub SayfalarDağıt()
 
Dim syf As Variant, i As Long, sn As Long, Sd As Worksheet
Dim sut As Integer, sat As Long
 
Set Sd = Sheets("DATA")
 
sut = Sd.Cells(1, Columns.Count).End(xlToLeft).Column
sat = Sd.Cells(Rows.Count, "B").End(xlUp).Row
 
For i = 1 To Worksheets.Count
    With Sheets(i)
        If .Name <> "DATA" Then
            .Cells.ClearContents
            Sd.Rows(1).Copy .Range("A1")
        End If
    End With
Next i
 
On Error Resume Next
For i = 2 To Sd.Cells(Rows.Count, "B").End(xlUp).Row
    syf = Format(Sd.Cells(i, "B"), "mmmm yy")
    sn = Sheets(syf).Cells(Rows.Count, "B").End(xlUp).Row + 1
    Sd.Range(Sd.Cells(i, "A"), Sd.Cells(i, sut)).Copy Sheets(syf).Cells(sn, "A")
    Sheets(syf).Cells.EntireColumn.AutoFit
Next i
 
MsgBox "Aktarım Tamamlandı.", vbInformation, Application.UserName
End Sub

.

 

[cems]

Sayın Ömer ,

Kodlar mükemmel çalıştı, saniyeler içinde aktarım gerçekleşti Ellerinize sağlık.
Tek bir yerden emin olamadım , taşınan kodları silmemesi için

.Cells.ClearContents önüne ' koyarak atlanmasını sağladım zira data sayfası sürekli altına eklene eklene gidecek ve her aktarımda yeni baştan aktarma yaparak eksiksiz taşınmış olacak.
Bir tek şey kaldı. DATA sayfası dışındaki (KİLİTLENEREK BIRAKILACAK) sayfaları
a) Aktarma başlarken sayfa kilidinin acılması
b) Aktarma bitince sayfa kilidinin calısması
yani kullanıcı aktarılmıs verilere dokunamayacak

 

[Ömer]

Bu şekilde deneyiniz..

Veri silinmeyecekse;

Sub Sayfalara_Aktar()
 
Dim i As Long, son As Long, sut As Integer, syf As String
 
Sheets("DATA").Select
 
sut = Cells(1, Columns.Count).End(xlToLeft).Column
 
Application.ScreenUpdating = False
 
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    syf = Format(Cells(i, "B").Value, "mmmm yy")
    Sheets(syf).Unprotect "[COLOR=red]deneme[/COLOR]" [COLOR=green]'koruma şifresi[/COLOR]
    son = Sheets(syf).Cells(Rows.Count, "B").End(xlUp).Row + 1
    Rows(1).Copy Sheets(syf).Range("A1")
    Range(Cells(i, "A"), Cells(i, sut)).Copy Sheets(syf).Cells(son, "A")
    Sheets(syf).Cells.EntireColumn.AutoFit
    Sheets(syf).Protect "[COLOR=red]deneme[/COLOR]"[COLOR=green] 'koruma şifresi[/COLOR]
Next i
 
MsgBox "Aktarım Tamamlandı.", vbInformation, Application.UserName
Application.ScreenUpdating = True
End Sub

Veri silinecekse;

Sub Sayfalara_Aktar()
Dim i As Long, son As Long, sut As Integer, syf As String, j As Integer
 
Sheets("DATA").Select
 
sut = Cells(1, Columns.Count).End(xlToLeft).Column
 
Application.ScreenUpdating = False
 
For j = 1 To Worksheets.Count
    With Sheets(j)
        If .Name <> "DATA" Then
            .Unprotect "[COLOR=red]deneme[/COLOR]"
            .Cells.ClearContents
        End If
    End With
Next j
 
For i = 2 To Cells(Rows.Count, "B").End(xlUp).Row
    syf = Format(Cells(i, "B").Value, "mmmm yy")
    Rows(1).Copy Sheets(syf).Range("A1")
    son = Sheets(syf).Cells(Rows.Count, "B").End(xlUp).Row + 1
    Range(Cells(i, "A"), Cells(i, sut)).Copy Sheets(syf).Cells(son, "A")
    Sheets(syf).Cells.EntireColumn.AutoFit
Next i
 
For j = 1 To Worksheets.Count
    With Sheets(j)
        If .Name <> "DATA" Then
            .Protect "[COLOR=red]deneme[/COLOR]"
        End If
    End With
Next j
 
MsgBox "Aktarım Tamamlandı.", vbInformation, Application.UserName
Application.ScreenUpdating = True
End Sub

.

 

[cems]

Ömer bey ,

Veri silinecekse.. kodları tam ve istenen şekilde çalıştı .

Çok ama Çok teşekkür ederim üstad

 

[Ömer]

Rica ederim, iyi çalışmalar..