3 kritere gore verilerin aktarilmasi

[Eser Gökay]

arkadaslar makro ile 3 kritere gore bir sayfadan digeri veri aktarma ile ilgili problemim var. ayrıntı dosyadadir. tesekkur ediyorum

 

[Eser Gökay]

arkadaslar henuz bir okuyan var.

 

[Recep İpek]

Aşağıdaki kodları kullanabilirsiniz.

Sub Düzenle()
On Error Resume Next
Set s1 = Sheets("Gel")
Set s2 = Sheets("Gel2")
s2.Range("b2:v201").ClearContents
s2.Range("b203:v402").ClearContents
s2.Range("b404:v703").ClearContents
For i = 5 To s1.[b65536].End(3).Row
If s1.Cells(i, "y").Value = "Öz" Then
sat = s2.Range("b2:b201").End(3).Row + 1
s2.Range(s2.Cells(sat, "b"), s2.Cells(sat, "v")).Value = s1.Range(s1.Cells(i, "e"), s1.Cells(i, "y")).Value
ElseIf s1.Cells(i, "y").Value = "Kiralık" Then
sat = s2.Range("b203:b402").End(3).Row + 1
s2.Range(s2.Cells(sat, "b"), s2.Cells(sat, "v")).Value = s1.Range(s1.Cells(i, "e"), s1.Cells(i, "y")).Value
ElseIf s1.Cells(i, "y").Value = "İhracat" Then
sat = s2.Range("b404:b703").End(3).Row + 1
s2.Range(s2.Cells(sat, "b"), s2.Cells(sat, "v")).Value = s1.Range(s1.Cells(i, "e"), s1.Cells(i, "y")).Value
End If
Next i
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Eser Gökay]

sayın ripek

ilgilendiginiz icin tesekkur ediyorum. ancak yazdiginiz kodlar tam olarak isimi cozmedi, soyle ki yapmak istedigimi yapiyor ancak arama sonucunda sadece o kriterle ilgili buldugu son satiri aktariyor. oysa bana butun veriler lazım. tekrar tesekkur ediyorum.

 

[Recep İpek]

Kodları aşağıdaki şekilde değiştiriniz.

Sub Düzenle()
On Error Resume Next
Set s1 = Sheets("Gel")
Set s2 = Sheets("Gel2")
s2.Range("b2:v201").ClearContents
s2.Range("b203:v402").ClearContents
s2.Range("b404:v703").ClearContents
For i = 5 To s1.[b65536].End(3).Row
If s1.Cells(i, "y").Value = "Öz" Then
sat = WorksheetFunction.CountA(s2.Range("b2:b201")) + 1
s2.Range(s2.Cells(sat + 1, "b"), s2.Cells(sat + 1, "v")).Value = s1.Range(s1.Cells(i, "e"), s1.Cells(i, "y")).Value
ElseIf s1.Cells(i, "y").Value = "Kiralık" Then
sat = WorksheetFunction.CountA(s2.Range("b202:b402")) + 1
s2.Range(s2.Cells(201 + sat, "b"), s2.Cells(201 + sat, "v")).Value = s1.Range(s1.Cells(i, "e"), s1.Cells(i, "y")).Value
ElseIf s1.Cells(i, "y").Value = "İhracat" Then
sat = WorksheetFunction.CountA(s2.Range("b403:b703")) + 1
s2.Range(s2.Cells(402 + sat, "b"), s2.Cells(402 + sat, "v")).Value = s1.Range(s1.Cells(i, "e"), s1.Cells(i, "y")).Value
End If
Next i
MsgBox "Bitti"
Set s1 = Nothing
Set s2 = Nothing
End Sub

 

[Eser Gökay]

sayın ripek

cok tesekkur ediyorum. elinize saglik. ilk denemelerime gore problemsiz calismaktadir. gercek verilerimle tam olarak test ettikten sonra bir problem olmasi durumunda tekrar size donersem umarim rahatsiz olmazsiniz. tekrar tesekkur ediyorum.