Aktarma ve raporlama sorunu

[argo619]

Ekteki dosyamda belirttiğim üzere E sütününde belirtilen YANGIN ÇEŞİDİ ne göre mesela ev yangını olanları ev yangını sayfasına kurtarma olanlarını kurtarma sayfasına nasıl aktarabiliriz.
Değerli üstatlarıma saygılarımla

 

[Orion1]

Çok basit .
Dosyanız ekte.

Sub aktar()
Dim sh As Worksheet, sat As Long, i As Long
Application.ScreenUpdating = False
With Sheets("Sayfa1")
    For i = 2 To .Cells(65536, "E").End(xlUp).Row
        Set sh = Sheets(.Cells(i, "E").Value)
        sat = sh.Cells(65536, "E").End(xlUp).Row + 1
        sh.Range("A" & sat & ":I" & sat).Value = _
        .Range("A" & i & ":I" & i).Value
    Next i
End With
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "Aktarma İşlemi Tamalandı", vbOKOnly + vbInformation, "AKTARMA"
End Sub

 

[argo619]

Ilginize tşk

değerli üstadım hakkınızı helal edin
tek kelime ile mükemmelsiniz allah razı olsun
YALNIZ: Satır sayısı 600/700 e kadar gidebilir aşağı doğru olan bilgileri aktarmayıbaşaramadım

 

[Orion1]

İstediği kadar satır olsun hiç farketmez.Kodlar sayfa ismini E sütunundan alıp ilgili sayfaya verileri aktarıyor.
Sizin satırlarınız arasında boşluk olduğu için E sütunundaki hücrede boş oluyor.Ne yapsın zavallı excelim arıyor arıyor o sayfayı bulamıyor.Sonunda sigortaları atıyor hata veriyor.Çünkü isimsiz bir sayfa yok sizn sayfalarınızn içinde zaten isimsiz sayfada olmaz .Mutlaka bir ismi olur.Birde şu önemli.E sütununda yazılan sayfa'lar dosyanızda yoksa veya değişikse yine hata vercektir.
Sayfa ismleri ile E sütunundaki ismler birebir uymalıdır.Ben boşlukları kaldırdım.Sorunsuz çalıştı.Sizde boşluk vermeyin.

 

[argo619]

Hocam ilgi ve alakanıza teşekkürler bağışlayın
sorun halledildi sağolun eksik olmayın

 

[suatbayhan]

Ben de makrosuz deneyeyim dedim.
Ama daha uzun sürüyor.

 

[revival1905]

Çok basit .
Dosyanız ekte.

Sub aktar()
Dim sh As Worksheet, sat As Long, i As Long
Application.ScreenUpdating = False
With Sheets("Sayfa1")
    For i = 2 To .Cells(65536, "E").End(xlUp).Row
        Set sh = Sheets(.Cells(i, "E").Value)
        sat = sh.Cells(65536, "E").End(xlUp).Row + 1
        sh.Range("A" & sat & ":I" & sat).Value = _
        .Range("A" & i & ":I" & i).Value
    Next i
End With
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "Aktarma İşlemi Tamalandı", vbOKOnly + vbInformation, "AKTARMA"
End Sub

sn Evren Gizlen yukarıda aktar butonuna yanlışlıkla iki kez basarsak tüm bilgileri ikinci kez ilgili sayfalara gönderiyor yani bilgiler mükerrer oluyor aynı bilginin ikinci kez gönderilmesini engelleyebilirmiyiz