Düşey arada makro yazmak

[Kaliteci Mücahit]

Arkadaşlar merhaba,

Aşağıda örnek gönderdiğim excelde;

2.Sayfadaki A sütunundaki ile 1 Sayfanın A sütunundaki aynı olan tanımlamalarında,

2.sayfaki Mesaure Tol- Tol+ değerlerinin 1. sayfadaki o tanımlamadaki satırlara sütunlara doldurmasını istiyorum. Bu şekilde makro kodları konusunda yardımlarınızı bekliyorum. Biliyorum biraz çok şey istedim Ama yardımcı olacağınızı düşünüyorum.
Teşekkür ederim.

 

[muygun]

Merhaba;
Eki deneyin.
İyi çalışmalar.

 

[tahsinanarat]

Kodlar Asi_Kral'a ait kodlardır, bir modüle yapıştırıp denermisiniz,

Option Explicit
Sub verileri_bul_getir_1967()
'Konu       :   Karşılığını Bul ve Sonuçu Getir
'Mail       :   m.batu.1967@gmail.com
'Msn        :   m.batu.1967@hotmail.com.tr
'Coder By   :   asi_kral_1967
Dim asi As Worksheet, kral As Long
Dim a As Long, b As Long
    Sheets("9D2-AM2-2015-REV_00").Select
    Range("a1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Sheets("Sayfa1").Select
Set asi = Sheets("9D2-AM2-2015-REV_00")
kral = asi.Range("A" & Rows.Count).End(xlUp).Row
Range("c15:g" & Rows.Count).ClearContents
For a = 1 To Range("A" & Rows.Count).End(xlUp).Row
If WorksheetFunction.CountIf(asi.Range("a:a"), Cells(a, "A")) > 0 Then
b = WorksheetFunction.Match(Cells(a, "A"), asi.Range("a:a"), 0)
asi.Range("d" & b & ":e" & b).Copy Destination:=Range("d" & a)
asi.Range("f" & b).Copy Destination:=Range("c" & a)
End If: Next
    Sheets("9D2-AM2-2015-REV_00").Select
    Range("a1").Select
    Selection.Delete Shift:=xlUp
    Sheets("Sayfa1").Select
'MsgBox "İşlem Tamamlandı", vbInformation, "asi_kral_1967"
End Sub

Sn. muygun hocam cevap vermiş zaten, gönderdikten sonra farkettim.

 

[Kaliteci Mücahit]

Teşekkür ederim arkadaşlar muygun ustamın yazdığı makro zaten çalışıyor diğerinde 404 hatası verdi