kriter eşitliğine göre sütuna kopyala yapıştır

[hayri tekin]

Selam arkadaşlar.Ekli tablomda kriter eşitliğine göre sütundaki sayıları eşitliğin sağlandığı sütuna yazdırmak istiyorum.

 

[hayri tekin]

dosyamdaki açıklamada hata yapılmıştır.Doğrusu "A2 eşitliğine" uyan olacaktır.

 

[Orion1]

Dosyanız ekte.

Sub aktar()
Dim k As Range
Sheets("Sayfa1").Select
Set k = Range("B2:IV2").Find(Range("A2").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    Range(Cells(3, k.Column), Cells(32, k.Column)).Value = _
    Range("A3:A32").Value
    MsgBox "İşlem tamam..!!"
End If
Set k = Nothing
End Sub

 

[Recep İpek]

Aşağıdaki kodarı deneyiniz.

Sub Aktar()
Application.ScreenUpdating = False
Sheets("Sayfa1").Select
ara = 0
For i = 2 To 13
If CDate(Cells(2, i)) = CDate(Range("a2")) Then
ara = i
Exit For
End If
Next i
If ara = 0 Then
MsgBox "Kayıt Edilecek Tarih Bulunamadı"
Exit Sub
End If
Range("A3:A32").Copy
Cells(3, ara).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("a2").Select
Application.CutCopyMode = False
Sheets("Sayfa2").Select
Application.ScreenUpdating = True
MsgBox "Bitti"
Set s1 = Nothing
End Sub

 

[hayri tekin]

Dosyanız ekte.

Sub aktar()
Dim k As Range
Sheets("Sayfa1").Select
Set k = Range("B2:IV2").Find(Range("A2").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    Range(Cells(3, k.Column), Cells(32, k.Column)).Value = _
    Range("A3:A32").Value
    MsgBox "İşlem tamam..!!"
End If
Set k = Nothing
End Sub

Sayın EVREN GİZLEN hocam,
Çok teşekkürler,emeğinize ve ilginize..

 

[hayri tekin]

Sayın RECEP İPEK hocam
Çok teşekkürler..