sayfalara şartlı aktarmak

[arifbirgen]

Değerli hocalarım
örnekteki gibi şartlı olarak aktarma yapabilirmiyiz.Sitedeki birçok
örneği inceledim tek sutuna göre aktarım var.Yardımcı olursanız memnun
olurum.

 

[Orion1]

Dosyanız ekte.

 

[arifbirgen]

sn Hocam Evren Gizlen
Yine cevabınızdan dolayı teşekkür ederim.Hocam sayfa1 e sonradan eklenecek isimler aktarılması için tıklandığında, önceki isimler tekrar
aktarılıyor.Önceki isimler aktarılmış sayfalarda mükerrer olmakta,bu sorunuda
hallederseniz sevinirim.İyi çalışmalar.

 

[Orion1]

sn Hocam Evren Gizlen
Yine cevabınızdan dolayı teşekkür ederim.Hocam sayfa1 e sonradan eklenecek isimler aktarılması için tıklandığında, önceki isimler tekrar
aktarılıyor.Önceki isimler aktarılmış sayfalarda mükerrer olmakta,bu sorunuda
hallederseniz sevinirim.İyi çalışmalar.

Bu tür durumları aslında sorunuzun ilk başında açıklmanız gerekiyor.
Sizin nasıl kullanacağınız bilemediğimizden dolayı tahmini bir şey hazırlıyoruz.
Mesela ben dağa önceki kayıtların altına yeni kayıtları gireceğinizi düşündüm.
Şimdi Önce ilgili sayfalardaki A:E aralığını siliyor sonra kayıt yapıyor.

Sub aktar()
Dim syf_ad As String, son_sut As Integer, son_sat As Long, sat As Long
Dim syfsat As Long, adr As String
Sheets("Sayfa1").Select
son_sut = Cells(7, 256).End(xlToLeft).Column
son_sat = Cells(65536, "D").End(xlUp).Row
Application.ScreenUpdating = False
If son_sut < 5 Then Exit Sub
For i = 2 To Worksheets.Count
adr = Range(Cells(8, "E"), Cells(son_sat, son_sut)).Address
    If WorksheetFunction.CountIf(Range(adr), Sheets(i).Name) >= 1 Then
        Sheets(i).Range("A2:E65536").ClearContents
    End If
Next i
For i = 8 To son_sat
    For k = 5 To son_sut
        On Error Resume Next
        If Cells(i, k).Value <> "" Then
            syf_ad = Cells(i, k).Value
            syfsat = Sheets(syf_ad).Cells(65536, "D").End(xlUp).Row + 1
            If syfsat >= 65533 Then
                MsgBox "[ " & syf_ad & " ] İsimli sayfada satır doldu..!!" _
                & vbLf & "Bu sayfaya kayıt yapılmadı..!!", vbCritical, "DİKKAT"
                GoTo atla
            End If
            Sheets(syf_ad).Cells(syfsat, "A").Value = syfsat
            Sheets(syf_ad).Cells(syfsat, "B").Value = Cells(i, "B").Value
            Sheets(syf_ad).Cells(syfsat, "C").Value = Cells(i, "C").Value
            Sheets(syf_ad).Cells(syfsat, "D").Value = Cells(i, "D").Value
            Sheets(syf_ad).Cells(syfsat, "E").Value = Cells(7, k).Value
atla:
        End If
    Next k
Next i
    Application.ScreenUpdating = True
    MsgBox "İşlem Tamamlandı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[arifbirgen]

sn hocam Evren GİZLEN
yardımlarınızdan dolayı teşekkür ederim.zahmet oluyor, sizlerin sayesinde
birşeyler yapmaya ve öğrenmeye çalışıyoruz.Makrodan anlamıyorum.Aktarmalarda S,T,Z sayfalarında farklı aktarma yapıyor.önceki kayıtlarıda tekrarlamakta.Birde 30 kadar sayfalara aktarma yapacağımı düşünerek yardımcı olursanız memnun olurum.Sağlık ve başarı dilerim.

 

[Orion1]

sn hocam Evren GİZLEN
yardımlarınızdan dolayı teşekkür ederim.zahmet oluyor, sizlerin sayesinde
birşeyler yapmaya ve öğrenmeye çalışıyoruz.Makrodan anlamıyorum.Aktarmalarda S,T,Z sayfalarında farklı aktarma yapıyor.önceki kayıtlarıda tekrarlamakta.Birde 30 kadar sayfalara aktarma yapacağımı düşünerek yardımcı olursanız memnun olurum.Sağlık ve başarı dilerim.

Durum düzeltildi.
Dosyayı 4 numaralı mesajdan indrebilirsiniz.