Hücrenin bulunduğu satırı süzme

[sementesee]

Ekteki dosyada bulunan GENEL arıza takip formu sayfasındaki makina no'suna göre satırda bulunan verileri alıp diğer çalışma sayfalarındaki makina sicil kartlarına dağıtmak istiyorum.Yardımcı olabilir misiniz?

 

[Orion1]

Dosyanız ektedir.

Sub ariza_takip()
Dim i As Long, sat As Long, sh As Worksheet
Sheets("GENEL").Select
Application.ScreenUpdating = False
For i = 8 To Cells(65536, "B").End(xlUp).Row
    Set sh = Worksheets(CStr(Cells(i, "B").Value))
    On Error GoTo hata
    On Error GoTo 0
    sat = sh.Cells(65536, "A").End(xlUp).Row + 1
    If sat >= 65533 Then
        MsgBox "[ " & sh.Name & " ] sayfasında satır doldu." & _
        vbLf & "Bu sayfaya " & i & "ncü satırdaki veri kaydedilmedi.", vbCritical, "UYARI"
        GoTo atla
    End If
    sh.Cells(sat, "A").Value = Range("E4").Value
    sh.Cells(sat, "B").Value = Cells(i, "C").Value
    sh.Cells(sat, "C").Value = Cells(i, "H").Value
    sh.Cells(sat, "D").Value = Cells(i, "I").Value
    sh.Cells(sat, "F").Value = Cells(i, "K").Value
atla:
Next i
Application.ScreenUpdating = True
MsgBox "Aktarma Başarı ile gerçekleşti.", vbOKOnly + vbInformation, "E V R E N"
Exit Sub
hata:
MsgBox Str(Cells(i, "B").Value) & " İsminde bir sayfa yok." & vbLf & _
i & " satırı kaydedilmedi.", vbCritical, "UYARI"
GoTo atla
End Sub

 

[sementesee]

Öncelikle yardımınız için teşekkürler.Tek bir sorunum kaldı ; "AKTAR" butonunu her kullandığımda önceden aktardığı bilgileri de aktarıyor,sayfalara sürekli kayıt olacağından yeni satırlarla beraber eskileri de aktaracak bunu engelleyebilir miyiz?

 

[Orion1]

Öncelikle yardımınız için teşekkürler.Tek bir sorunum kaldı ; "AKTAR" butonunu her kullandığımda önceden aktardığı bilgileri de aktarıyor,sayfalara sürekli kayıt olacağından yeni satırlarla beraber eskileri de aktaracak bunu engelleyebilir miyiz?

O zaman bir sayfa dağa yapın.
Oradan sürekli aktarılsın.Aktarlıldıktan sonra sayfa silinsin.Akatrırken hem diğer sayfalara aktarsın hemde sizin anasayfanızdaki yere aktarsın.Başka türlü nereden bilecek hangisini aktardı hangisini aktarmadı.Benim aklıma gelen en doğru çözüm bu.Başka şeylerde aklıma geldi ama onlar sakıncalı.Hatalı işlem yapılabilir.
Eğer dosyanızı öyle hazırlayıp yollarsanız ben kodlarıda o şekle göre revize ederim.

 

[sementesee]

Yeni bir sayfa oluşturdum dosyayı ekte yolluyorum.

 

[Orion1]

Yeni bir sayfa oluşturdum dosyayı ekte yolluyorum.

Dosyanız ekte.

Sub ariza_takip()
Dim i As Long, sat As Long, sh As Worksheet, s1 As Worksheet, sat2 As Long, k As Byte
Sheets("GİRİŞ").Select
Set s1 = Sheets("GENEL")
Application.ScreenUpdating = False
    Set sh = Worksheets(CStr(Cells(1, "B").Value))
    On Error GoTo hata
    On Error GoTo 0
    sat2 = s1.Cells(65536, "B").End(xlUp).Row + 1
    If sat2 >= 65533 Then
        MsgBox "[ GENEL ] sayfasında satır doldu." & _
        vbLf & "veri kaydedilmedi.", vbCritical, "UYARI"
        GoTo atla
    End If
    sat = sh.Cells(65536, "A").End(xlUp).Row + 1
    If sat >= 65533 Then
        MsgBox "[ " & sh.Name & " ] sayfasında satır doldu." & _
        vbLf & "Bu sayfaya veri kaydedilmedi.", vbCritical, "UYARI"
        GoTo atla
    End If
    s1.Range("E4").Value = Range("B2").Value
    s1.Range("E5").Value = Range("B3").Value
    For k = 4 To 8
        s1.Cells(sat2, k - 2).Value = Cells(k, 2).Value
    Next k
    For k = 9 To 12
        s1.Cells(sat2, k - 1).Value = Cells(k, 2).Value
        sh.Cells(sat, k - 6).Value = Cells(k, 2).Value
    Next k
    sh.Cells(sat, "A").Value = Range("B2").Value
    sh.Cells(sat, "B").Value = Range("B5").Value
atla:
Application.ScreenUpdating = True
MsgBox "Aktarma Başarı ile gerçekleşti.", vbOKOnly + vbInformation, "E V R E N"
Exit Sub
hata:
MsgBox CStr(Cells(1, "B").Value) & " İsminde bir sayfa yok." & vbLf & _
"Veri kaydedilmedi.", vbCritical, "UYARI"
End Sub

 

[sementesee]

Elinize sağlık teşekkürler

 

[Orion1]

Elinize sağlık teşekkürler

Rica ederim.
İyi çalışmalar.