Soru Hücreleri Kopyalayıp Özel Yapıştır (Değerler ve Sayı Biçimini-İşlemi Ters Çevirerek Yapıştırma)

[officer08]

Üstadlar bi yardımcı olursanız sevinirim.

"kayıt" isimli sayfada:
D20'ye yazılan kayıt numarasına göre aynı sayfadaki D22, D23, D24, D25, D26, D27, D28 hücrelerine veri tabanından verileri getiriyorum.

şimdi amacım VERİ DÜZELT TUŞU yapmak.

D22, D23, D24, D25, D26, D27, D28 hücrelerinden birinde veya birkaçında kişi manuel değişiklik yapacak sonra yazılması gereken kodlar lazım

Yani istediğim kod:

"kayıt" isimli sayfadaki D22, D23, D24, D25, D26, D27, D28 hücrelerini kopyalayacak aynı sayfadaki D20 hücresindeki kayıt numarasını , "liste" isimli veri tabanı sayfasında A sütununda arayacak bulunca hemen yanında sıralanan B, C, D, E, F, G, H sütunundaki denk gelen satır hücrelerine özel yapıştır ile Değerler ve sayı biçimlerini işlemi tersine çevirerek yapıştıracak. Böylelikle veritabınından getirdiğimiz bilgileri değişmiş haliyle aynı yerine yapıştırarak düzeltme işlemi yapacağım.

 

[PLİNT]

Merhaba
Aşağıdaki kodları denermisiniz?

Sub yenıle()
Dim s1 As Worksheet, s2 As Worksheet
Dim r As Range, y As Long
Set s1 = Sheets("KAYIT")
Set s2 = Sheets("LİSTE")
Set r = s2.[A:A].Find(s1.[D20].Value, , , xlWhole)
If Not r Is Nothing Then
For y = 2 To 8
'If Trim(s1.Cells(20 + y, "D").Value) <> "" Then
s2.Cells(r.Row, y).NumberFormat = s1.Cells(20 + y, "D").NumberFormat
s2.Cells(r.Row, y).Value = s1.Cells(20 + y, "D").Value
'End If
Next
End If
s2.Activate
s2.Cells(r.Row, r.Column).Select
End Sub

 

[officer08]

PLINT cevabın için teşekkür ederim. Denedim ama s.2 Cells.(r.Row, Column).Select kısmında uyarı veriyor. Veri tabanında kayıt nonun yanındaki satırı bulup seçiyor ama orada kalıyor

 

[PLİNT]

Kodların sonundaki bu bölüm;
'...
'
s2.Activate
s2.Cells(r.Row, r.Column).Select
End Sub
( s.2 Cells.(r.Row, Column).Select değilde s2.Cells.(r.Row, r.Column).Select olmalı öyle yazılmış ise zaten yanlış)
işlemin sonunda "LİSTE" Sayfasını açılıp düzeltme yapılan yeri görebilmeniz içindi; isterseniz silin
veya

'....
'............diğer kodlar
'.....
s2.Activate
r.Select '****************
End Sub

Şeklinde deneyin

 

[PLİNT]

Merhaba
Aşağıdaki kodlarda; aranan "D20" hücresinin boş olma ihtimali için ek bulunuyor bu şekilde kullanınız

Sub yenıle()
Dim s1 As Worksheet, s2 As Worksheet
Dim r As Range, y As Long
Set s1 = Sheets("KAYIT")
Set s2 = Sheets("LİSTE")
Set r = s2.[A:A].Find(s1.[D20].Value, , , xlWhole)
If Not r Is Nothing And Trim(s1.[D20].Value) <> "" Then
For y = 2 To 8
s2.Cells(r.Row, y).NumberFormat = s1.Cells(20 + y, "D").NumberFormat
s2.Cells(r.Row, y).Value = s1.Cells(20 + y, "D").Value
Next
s2.Activate
r.Select
Else
MsgBox "Aranan veri bulunamadı"
End If
End Sub

 

[officer08]

PLINT son dediğini yaptım artık uyarı vermiyor ancak veri tabanında ilgili satırı seçmesine rağmen yazdığım değişikliği yapmıyor

 

[PLİNT]

Ek dosyayı denermisiniz
https://www.dosyaupload.com/b981
Olmazsa; dosya örneği eklersiniz

 

[officer08]

PLİNT yolladığın tam benim istediğim şey ellerine sağlık ancak bunu benim excele aktardığımda olmuyor yani sorun bende yarın biraz daha uğraşacağım nerede hata yaptığımı bulmaya çalışacağım