hücre bilgilerini başka sayfaya sıralı kaydedilmesi

[taseraydin]

Değerli Arkadaşlar bir sayfada belli hüçrelere yazılmış bilgileiri diğer sayfada ilgili kolonlara sıralı yazdırma işlemi konusunda yardımlarınızı bekliyorum
Sevgiler Saygılar.

 

[Orion1]

Ekli dosyayı inceleyiniz.

Sub aktar()
Dim i As Byte, sat As Long
Sheets("Kayıt Giriş").Select
Set s1 = Sheets("TAHAKKUKLİSTESİ")
Set s2 = Sheets("Kayıt Giriş")
sat = s1.Cells(65536, "B").End(xlUp).Row + 1
s1.Cells(sat, "A").Value = sat - 2
For i = 4 To 11
    s1.Cells(sat, i - 2).Value = Cells(i, "C").Value
Next i
Set s1 = Nothing
Set s2 = Nothing
MsgBox "AKTARMA TAMAMLANDI..!!"
End Sub

 

[taseraydin]

ilginize içten teşekür ederim
elinize sağlık
bu arada görev aldığı kurum ve dosya no daha önce kaydedilmişse kayıt işlemi engellenebilirmi ve uyarıda verirse mükemmel olur

 

[Orion1]

ilginize içten teşekür ederim
elinize sağlık
bu arada görev aldığı kurum ve dosya no daha önce kaydedilmişse kayıt işlemi engellenebilirmi ve uyarıda verirse mükemmel olur

Ekli dosyayı inceleyiniz.

Sub aktar()
Dim i As Byte, sat As Long
Sheets("Kayıt Giriş").Select
Set s1 = Sheets("TAHAKKUKLİSTESİ")
Set s2 = Sheets("Kayıt Giriş")
Set k = s1.Range("D3:D65536").Find(s2.Range("C6"), LookIn:=xlValues, lookat:=xlWhole)
If Not k Is Nothing Then
    If MsgBox("Görev aldığı kurum : " & s2.Range("C6").Value & " Dağa önceden kaydedilmiş." & _
    vbLf & "Tekrardan kayıt etmek istiyormusunuz..!!", vbYesNo) = vbNo Then
        Set k = Nothing
        Exit Sub
    End If
End If
Set c = s1.Range("E3:E65536").Find(s2.Range("C7"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
    If MsgBox("Dosya No : " & s2.Range("C7").Value & " Dağa önceden kaydedilmiş." & _
    vbLf & "Tekrardan kayıt etmek istiyormusunuz..!!", vbYesNo) = vbNo Then
        Set c = Nothing
        Exit Sub
    End If
End If

sat = s1.Cells(65536, "B").End(xlUp).Row + 1
s1.Cells(sat, "A").Value = sat - 2
For i = 4 To 11
    s1.Cells(sat, i - 2).Value = Cells(i, "C").Value
Next i
Set s1 = Nothing
Set s2 = Nothing
Set k = Nothing
Set c = Nothing
MsgBox "AKTARMA TAMAMLANDI..!!"
End Sub

 

[taseraydin]

TeŞekÜr

Elinize sağlık mükemmel oldu Teşekür ederim.

 

[Orion1]

Elinize sağlık mükemmel oldu Teşekür ederim.

Rica ederim.
İyi çalışmalar.

 

[taseraydin]

üstadım yeni fark ettim sadece görev aldığı aynı ise uyarı veriyor oysa dosya numarası ile birlikte aynı olursa uyarı vermesi lazım kurum birden fazla olabilir dosya numarasıda başka kurumlara ait aynı numara tesadür edebilir her iki koşul aynı olması durumunda uyarı verebilirme bu saatte sizi uğraştırıyorum kusura bakmayın lütfen

 

[Orion1]

üstadım yeni fark ettim sadece görev aldığı aynı ise uyarı veriyor oysa dosya numarası ile birlikte aynı olursa uyarı vermesi lazım kurum birden fazla olabilir dosya numarasıda başka kurumlara ait aynı numara tesadür edebilir her iki koşul aynı olması durumunda uyarı verebilirme bu saatte sizi uğraştırıyorum kusura bakmayın lütfen

Ekli dsoyayı inceleyiniz.

Sub aktar()
Dim i As Byte, sat As Long
Sheets("Kayıt Giriş").Select
Set s1 = Sheets("TAHAKKUKLİSTESİ")
Set s2 = Sheets("Kayıt Giriş")
Set k = s1.Range("D3:D65536").Find(s2.Range("C6"), LookIn:=xlValues, lookat:=xlWhole)
Set c = s1.Range("E3:E65536").Find(s2.Range("C7"), LookIn:=xlValues, lookat:=xlWhole)
If Not k Is Nothing And Not c Is Nothing Then
    If MsgBox("Görev aldığı kurum : " & s2.Range("C6").Value & vbLf & "Dosya No : " & s2.Range("C7").Value & vbLf & "Dağa önceden kaydedilmiş." & _
    vbLf & "Tekrardan kayıt etmek istiyormusunuz..!!", vbYesNo) = vbNo Then
        Set c = Nothing: Set k = Nothing
        Exit Sub
    End If
End If

sat = s1.Cells(65536, "B").End(xlUp).Row + 1
s1.Cells(sat, "A").Value = sat - 2
For i = 4 To 11
    s1.Cells(sat, i - 2).Value = Cells(i, "C").Value
Next i
Set s1 = Nothing
Set s2 = Nothing
Set k = Nothing
Set c = Nothing
MsgBox "AKTARMA TAMAMLANDI..!!"
End Sub

 

[taseraydin]

çok faydalı olacak
teşekür ederim.
Hoşça,Dostca kalın
Saygılar,sevgiler

 

[Orion1]

çok faydalı olacak
teşekür ederim.
Hoşça,Dostca kalın
Saygılar,sevgiler

Rica ederim.
İyi çalışmalar.