Aktar

[mcetinkaya65]

Bir çalışmamda Cami denetim sayfasının C6 hücresinden başlayıp T stununa kadar devam eden verilerim var.Satır olarak ise değişiyor. Cami Denetim sayfasından Cami Arşiv sayfasının B4 hücresinden başlayp aşağı doğru arşivleyen bir makro yazılabilirmi? Sadece değerleri aktarsın Biçimlendirmede tablo sorunu çıkıyor
Saygılarımla.

 

[mcetinkaya65]

İşlem Tamam.

Sub Düğme69_Tıklat()
Dim erb As Worksheet, s As Worksheet
Set erb = Sheets("Cami Arşiv")
Set ebr = Sheets("Cami Denetim")
For x = 6 To ebr.Range("C65536").End(3).Row
aa = erb.Range("C65536").End(3).Row + 1
If ebr.Cells(x, 4).Value <> "" Then
erb.Cells(aa, 2) = ebr.Cells(x, 3).Value
erb.Cells(aa, 3) = ebr.Cells(x, 4).Value
erb.Cells(aa, 4) = ebr.Cells(x, 5).Value
erb.Cells(aa, 5) = ebr.Cells(x, 6).Value
erb.Cells(aa, 6) = ebr.Cells(x, 7).Value
erb.Cells(aa, 7) = ebr.Cells(x, 8).Value
erb.Cells(aa, 8) = ebr.Cells(x, 9).Value
erb.Cells(aa, 9) = ebr.Cells(x, 10).Value
erb.Cells(aa, 10) = ebr.Cells(x, 11).Value
erb.Cells(aa, 11) = ebr.Cells(x, 12).Value
erb.Cells(aa, 12) = ebr.Cells(x, 13).Value
erb.Cells(aa, 13) = ebr.Cells(x, 14).Value
erb.Cells(aa, 14) = ebr.Cells(x, 15).Value
erb.Cells(aa, 15) = ebr.Cells(x, 16).Value
erb.Cells(aa, 16) = ebr.Cells(x, 17).Value
erb.Cells(aa, 17) = ebr.Cells(x, 18).Value
erb.Cells(aa, 18) = ebr.Cells(x, 19).Value
erb.Cells(aa, 19) = ebr.Cells(x, 20).Value
End If
Next x
x = Empty
Set ebr = Nothing
Set erb = Nothing
End Sub

 

[vardar07]

Cami Arşiv sayfasına veri girince aktaran kod. Cami Arşiv sekmesi üzerinde sağ tıklayıp kod görüntüleyi tıklayın açılan sayfaya ekleyip sayfa üzerinde cami adını girince aktarım yapar.

Private Sub Worksheet_Change(ByVal Target As Range)
Set sd = Sheets("Cami Denetim")
Set sa = Sheets("Cami Arşiv")
If Intersect(Target, sa.Range("B4:B" & sa.Range("B" & Rows.Count).End(3).Row)+5) Is Nothing Then Exit Sub
Set alan = sd.Range("C6:C" & sa.Range("C" & Rows.Count).End(3).Row)
Set bul = alan.Find(sa.Cells(Target.Row, "B"))
If Not bul Is Nothing Then
i = bul.Row
For k = 3 To 19
If k <> 18 Then
sa.Cells(Target.Row, k) = sd.Cells(i, k + 1)
Else
sa.Cells(Target.Row, k) = Format(sd.Cells(i, k + 1), "dd.mm.yyyy")
End If
Next
Else
MsgBox "Girdiğiniz veri yanlış yada veri yok"
End If
End Sub

 

[mcetinkaya65]

İlginiz için teşekkür ederim.
Üstad bu makro nasıl çalışacak.

 

[vardar07]

Cami Arşiv sekmesi üzerinde sağ tıklayıp kod görüntüle'yi tıklayın açılan VBA sayfasına ekleyin. Cami Arşiv sayfası üzerinde B sütununa cami adını girip enter yapınca otomatik aktarım yapar.