Veri aktarma

[bebar]

Merhaba;

bir sekmeden diğer bir sekmeye benzer değerler kullanarak veri aktarımı yapmya çalışyorum. aşağıdaki gibi bir kod oluşturdum biraz acemiyim nerede yanlış yaptığımı söylerseniz sevinirim, dosyam ektedir.

Sub deneme()

Dim veriSatir As Long
Dim veriSutun As Long
Dim raporSatir As Long
Dim raporSutun As Long

Dim RaporGelenSutun As String
Dim VeriGelenStun As String

Dim RaporGelenKod As String
Dim VeriGelenkod As String
Dim varmi As String
Dim deger As Long
varmi = "yok"

veriSatir = Sheets("Veri").Cells(65536, 1).End(xlUp).Row
veriSutun = Sheets("Veri").Cells(3, 248).End(xlToLeft).Column

raporSatir = Sheets("Rapor").Cells(65536, 1).End(xlUp).Row
raporSutun = Sheets("Rapor").Cells(3, 248).End(xlToLeft).Column

For j = 3 To raporSutun
RaporGelenSutun = Sheets("Rapor").Cells(2, j).Value

For k = 3 To veriSutun
VeriGelenStun = Sheets("Veri").Cells(2, k).Value
If RaporGelenSutun = VeriGelenStun Then
For i = 2 To raporSatir
RaporGelenKod = Sheets("Rapor").Cells(i, 1).Value

For l = 2 To veriSatir
VeriGelenkod = Sheets("Veri").Cells(l, 1).Value
If RaporGelenKod = VeriGelenkod Then
varmi = "var"
deger = l
Exit For
End If

Next l

If varmi = "var" Then
Sheets("Rapor").Cells(i, j).Value = Sheets("Veri").Cells(deger, k).Value
End If

Next i
End If
Next k


Next j

End Sub

 

[numan şamil]

Merhaba

Sub getir()
Dim x, y As Long
Dim s1 As Worksheet, s2 As Worksheet
Set s1 = Sheets("veri")
Set s2 = Sheets("şablon")
son = s2.Cells(Rows.Count, "A").End(3).Row
s2.Range("B3:F" & son).ClearContents
Application.ScreenUpdating = False
For x = 3 To son
For y = 2 To 6
If s2.Range("A" & x).Value = s1.Range("A" & x).Value And s2.Range("b1").Value = s1.Cells(1, y).Value And s2.Range("b2").Value = s1.Cells(2, y).Value Then
s2.Range("B" & x).Value = s1.Cells(x, y).Value
End If
If s2.Range("A" & x).Value = s1.Range("A" & x).Value And s2.Range("c1").Value = s1.Cells(1, y).Value And s2.Range("c2").Value = s1.Cells(2, y).Value Then
s2.Range("C" & x).Value = s1.Cells(x, y).Value
End If
If s2.Range("A" & x).Value = s1.Range("A" & x).Value And s2.Range("e1").Value = s1.Cells(1, y).Value And s2.Range("e2").Value = s1.Cells(2, y).Value Then
s2.Range("E" & x).Value = s1.Cells(x, y).Value
End If
If s2.Range("A" & x).Value = s1.Range("A" & x).Value And s2.Range("f1").Value = s1.Cells(1, y).Value And s2.Range("f2").Value = s1.Cells(2, y).Value Then
s2.Range("F" & x).Value = s1.Cells(x, y).Value
End If
Next y
Next x
Application.ScreenUpdating = True
End Sub