Düşeyara ile gelen hücrenin biçimini kopyalama

[Tongunc]

Merhaba bu konuyu çok araştırdım ama bulamadım.

İlişikteki örnek dosyada sayfa 1 de veri tablosu var
A1 A ÜRÜNÜ B1 1,00TL
A2 B ÜRÜNÜ B2 2,00TL
A3 C ÜRÜNÜ B3 3,00TL

Sayfa 2 de aşağı açılan liste var. Listeden A,B,C ürünlerini seçiyoruz. Karşısında da DÜŞEYARA fonksiyonu ile fiyatı çıkıyor. Fakat bu fiyatlar 1,2,3 olarak geliyor. 1TL, 2TL, 3TL olarak gelmiyor. B1, B2, B3 hücreleri biçimleriyle birlikte gelsin istiyorum.

Bu konuda değerli yardımlarınızı rica ederim.

 

[bogazincocugu]

selamlar,

sadece sayfa 2 deki b2 hücresine düşeyarayla veri getiriyorsunuz...

direk hücrede sağa tıklayıp biçimlendirin...

 

[Tongunc]

Düşeyara ile gelen verinin biçimi kaynak listedeki veri ile aynı olsun

Fiyat geldikten sonra manuel olarak biçimlendirebilirim tabi ki.
Ama ben kaynak sayfadaki hücrede biçim ne ise, düşeyara ile gelen değerin de otomatik olarak aynı biçimde olmasını istiyorum.
Bu örnek tablonun gerçeğinde yüzlerce ürün olacak ve kimisinin alış fiyatı TL ile, kimisinin $ ile, € ile, veya IF ile olacak. Dolayısıyla her seferinde kaynak veriye bakıp, gelen veriyi aynı para cinsine manuel dönüştürmek mümkün değil.
Yine de ilginiz için teşekkürler.

 

[Korhan Ayhan]

Merhaba,

DÜŞEYARA yerine makro kullanırsanız istediğiniz sonuca kolaylıkla ulaşabilirsiniz.

 

[Tongunc]

Makro kullanmayı bilmiyorum

Evet, forumda buna benzer şeylerin makro ile yapılabildiğini gördüm ama makro kullanmayı hiç bilmediğim için bunları kendime adapte edemiyorum. Örnek dosyama ugun bir makro gönderilirse sevinirim. Teşekkürler.

 

[Korhan Ayhan]

Merhaba,

ALT+F11 ile kod penceresini açın.
INSERT menüsünden "Module" seçeneğini seçin.
Sağ tarafta açılan beyaz pencereye aşağıdaki kodu uygulayın.

Sub BUL_BİÇİMİYLE_AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, BUL As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    For X = 1 To S2.Cells(Rows.Count, 1).End(3).Row
        Set BUL = S1.Range("A:A").Find(S2.Cells(X, 1), , , xlWhole)
        If Not BUL Is Nothing Then
            BUL.Offset(0, 1).Copy
            S2.Cells(X, 2).PasteSpecial Paste:=xlPasteValues
            S2.Cells(X, 2).PasteSpecial Paste:=xlPasteFormats
        End If
    Next
    
    Application.CutCopyMode = False
    
    Set BUL = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Son olarak excel sayfanıza geri dönün dosyanızı kayıt edin.
ALT+F8 tuşlarına basıp ilgili makroyu çalıştırın.

Dilerseniz aşağıdaki linki inceleyerek makronuzu bir butona atayabilirsiniz.

Sayfada Buton-Düğme Oluşturmak ve Makro Atamak (Resimli Anlatım)

 

[Tongunc]

Elinize sağlık

Korhan Bey çok teşekkür ederim.
Ben 2 ay uğraşsam böyle bir makro oluşturamazdım.
Böylelikle makronun mantığını da anlamış oldum.
Örneğin B ürününün fiyatını $ yaptım, C ürününün fiyatını € yaptım. Açılır listeyi de aşağıya doğru kopyaladım.
Ürünü seçince fiyatın birimi (TL,$,€) otomatik değişecek sandım ama ürün listeden her seçildiğinde makroyu da yeniden çalıştırmak gerekiyormuş.
Listeden ürünü seçince makro otomatik olarak çalışabilir mi bilmiyorum ama böyle de sakıncası yok. Dediğiniz gibi makroya düğme de atadım, tıklayınca tüm ürünlerin para birimleri güncelleniyor.
Vakit ayırdığınız ve emek verdiğiniz için tekrar teşekkür ediyorum. Elinize sağlık.

 

[Korhan Ayhan]

Merhaba,

Makronun otomatik çalışmasını sağlayabiliriz. Bunun için ilgili kodları ilgili sayfanın hücre değişim olayına yazmak yeterli olacaktır.

"Sayfa2" isimli sayfa sekmesinin adı üzerinde sağ klik yapın ve KOD GÖRÜNTÜLE seçeneğini seçin.
Açılan pencereye aşağıdaki kodu uygulayın.
A sütunundaki listeden seçim yapıp sonucu gözlemleyin.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, BUL As Range
    
    If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Sayfa1")
    
    Set BUL = S1.Range("A:A").Find(Target, , , xlWhole)
    If Not BUL Is Nothing Then
        BUL.Offset(0, 1).Copy
        Target.Offset(0, 1).PasteSpecial Paste:=xlPasteValues
        Target.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats
    End If
    
    Application.CutCopyMode = False
    
    Set BUL = Nothing
    Set S1 = Nothing
    
    Application.ScreenUpdating = True
End Sub

 

[Tongunc]

Bir taşla iki kuş

Sayın Korhan Bey;
Ben de size sayfa2 nin adını değiştirince veya sayfayı başka bir adla kopyalayınca makro yine çalışır mı diye soracaktım. Makronun otomatik çalışması ile ilgili yazdığınız makro bu durumu da çözmüş oldu.
Nasıl teşekkür edeyim bilemiyorum. Allah sizden razı olsun.

 

[fkara]

Merhabalar,

Konuyu biraz hortlatmak gibi olacak ama bir konuda bu işlev hakkında hata alıyorum. Basit bir düzeltmedir diye tahmin ediyorum.

Bu sayfadaki kodu biraz kendime göre ayarladım ama hata alıyorum ve dosyayı kilitliyor.

İstediğim kısaca makronun bulduğu hücredeki biçimlendirmeyi aradığım hücre üzerine yapıştırması.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, BUL As Range

If Intersect(Target, Range("A:A")) Is Nothing Then Exit Sub

Application.ScreenUpdating = False

Set S1 = Sheets("Sayfa1")

Set BUL = S1.Range("b3:d25").Find(Target, , , xlWhole)
If Not BUL Is Nothing Then
BUL.Offset(0, 0).Copy
Target.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats
End If

Application.CutCopyMode = False

Set BUL = Nothing
Set S1 = Nothing

Application.ScreenUpdating = True
End Sub


Bu kodu yazıyorum. kırmızı ile işaretlenmiş yerdeki 1 i 0 yapınca yani aradığım hücre üzerine yapıştırmayı deneyince hata alıyorum. Bu hali ile devam edersem yanındaki hücreye biçimlendirmesini atıyor.

Ne yapmalıyım acaba?