Saylar arası veri aktarımı

[akmes]

Selamlar,
Sayfa1 den Sayfa3 ki listeye göre bazı verileri sayfa2 ye alıyoruz.Bu veriler, ektekten anlaşılacağı gibi birden fazla olunca hepsinin üzerine gidip tek tek entere basmak yerine bir makro yardımı ile hepsinin çalışmasını nasıl sağlayabiliriz.Ayrıca bu makroya tıkladığım zaman A4 ile F9, A14 ile F19 , A24 ile F29 bu şekilde giden aralıklarda kalan verilerinde silinip yenilerinin gelmesi gerek.Şimdiden teşekkür ederim

 

[halit3]

Selamlar,
Sayfa1 den Sayfa3 ki listeye göre bazı verileri sayfa2 ye alıyoruz.Bu veriler, ektekten anlaşılacağı gibi birden fazla olunca hepsinin üzerine gidip tek tek entere basmak yerine bir makro yardımı ile hepsinin çalışmasını nasıl sağlayabiliriz.Ayrıca bu makroya tıkladığım zaman A4 ile F9, A14 ile F19 , A24 ile F29 bu şekilde giden aralıklarda kalan verilerinde silinip yenilerinin gelmesi gerek.Şimdiden teşekkür ederim

Bu konuda daha önce cevap verdiğimi hatırlıyorum.

aşağıdaki kodu denermisiniz.

Sub Makro3()
Set Sh3 = Sheets("Sayfa3")
Set Sh2 = Sheets("Sayfa2")
Set Sh1 = Sheets("Sayfa1")
Sh2.Columns("A:G").ClearContents
Sh2.Columns("A:G").Interior.ColorIndex = xlNone
Sh2.Columns("A:G").Font.ColorIndex = 0
son = 2
satır = 0
For r = 2 To Sh3.Cells(Rows.Count, "a").End(3).Row
Sh2.Cells(son, 1) = Sh3.Cells(r, 1)
Sh2.Cells(son, 1).Interior.ColorIndex = 6
Sh2.Cells(son, 1).Font.ColorIndex = 3
sat = 1
Dim aranan As String
Dim Rng As Range
aranan = Sh3.Cells(r, 1)
If Trim(aranan) <> "" Then
With Sh1.Range("c:d")
Set Rng = .Find(What:=aranan, After:=.Cells(1), LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not Rng Is Nothing Then
satır = Rng.Row
Else
MsgBox "Sonuç yok"
End If
End With
End If
If satır > 0 Then
For i = satır To 6 Step -1
If Sh1.Cells(i, "c").Value = aranan Or Sh1.Cells(i, "d").Value = aranan Then
sat = sat + 1
If sat <= 6 Then
Sh2.Cells(son + sat, 1) = Sh1.Cells(i, 1)
Sh2.Cells(son + sat, 2) = Sh1.Cells(i, 2)
Sh2.Cells(son + sat, 3) = Sh1.Cells(i, 3)
Sh2.Cells(son + sat, 4) = Sh1.Cells(i, 4)
Sh2.Cells(son + sat, 5) = Sh1.Cells(i, 5)
Sh2.Cells(son + sat, 6) = Sh1.Cells(i, 6)
End If
End If
Next
End If
son = son + 10
Next r
MsgBox "işlem tamam"
End Sub

 

[akmes]

Bu konuda daha önce cevap verdiğimi hatırlıyorum.

aşağıdaki kodu denermisiniz.

Evet üstadım vermiştiniz.Sayfa3 işlemim yoktu.Şimdi tam istediğim gibi oldu.Çok sağolun teşekkür ederim.Elinize emeğinize sağlık.Tam istediğim gibi oldu.

 

[halit3]

Evet üstadım vermiştiniz.Sayfa3 işlemim yoktu.Şimdi tam istediğim gibi oldu.Çok sağolun teşekkür ederim.Elinize emeğinize sağlık.Tam istediğim gibi oldu.

İyi çalışmalar