[Çözüldü] Bir Hücredeki Veriyi Belirli Aralıkta Bulup Karşısındaki Hücreye Başka Bir Hücredeki Veriyi Kopyalayan Makro

Kilitli
malitogan
Mesajlar: 7
Kayıt: Cum Haz 30, 2023 12:53 pm
Adınız: Mehmet Ali
Soyadınız: Toğan

[Çözüldü] Bir Hücredeki Veriyi Belirli Aralıkta Bulup Karşısındaki Hücreye Başka Bir Hücredeki Veriyi Kopyalayan Makro

Mesaj gönderen malitogan »

Değerli arkadaşlar, hakkediş dosyasında kaydet ile ilgili bir problemim var. Yardımcı olabilirseniz memnun olurum.
Bilgi sayfasında Kaydet butonuna basınca, Özet sayfasında AZ5 hücresindeki veriyi Özet sayfası AD5:AD40 aralığında en son boş hücreye yapıştırıyor.
Ancak benim yapmak istediğim, Bilgi sayfasında Kaydet butonuna basınca, yine Bilgi sayfasında K1 hücresindeki veriyi Özet sayfasında A5:A40 aralığında arayıp bulacak, bulduğu satırın hizasında AD5:AD40 aralığındaki hücreye AZ5 hücresindeki veriyi yapıştıracak. K1 hücresindeki veriyi Özet sayfasında A5:A40 aralığında bulamazsa ve/veya AZ hücresi boşsa hiçbir işlem yapmayacak.

Not : İşlem yapılan sayfalar şifre korumalı, verilerin yer aldığı ve işlem yapılacak hücreler birleştirilmiş hücre.
malitogan
Mesajlar: 7
Kayıt: Cum Haz 30, 2023 12:53 pm
Adınız: Mehmet Ali
Soyadınız: Toğan

Re: Bir Hücredeki Veriyi Belirli Aralıkta Bulup Karşısındaki Hücreye Başka Bir Hücredeki Veriyi Kopyalayan Makro

Mesaj gönderen malitogan »

Arkadaşlar, benimle aynı problemi olan varsa eğer, sorunum aşağıdaki makro ile çözüldü. Umarım sizlerin de işine yarar.

Kod: Tümünü seç

Private Sub Kaydet()

Dim bilgi As Worksheet, ozet As Worksheet, aralik As Range

Dim ara As Range, tutar As Double, aranan As String, hcr As Range

Set ozet = Sheets("Özet")

Set bilgi = Sheets("Bilgi")

Set aralik = ozet.Range("A5:A40")

aranan = bilgi.Range("K1")

For Each hcr In aralik

    If aranan = hcr Then

    tutar = ozet.Range("AZ5")

        If tutar = Empty Then

        MsgBox "Tutar alanı boş olduğu için aktarım yapılamadı"

        Exit Sub

        Else

        ozet.Range("AD" & hcr.Row) = tutar

        GoTo 10

        End If

    End If

Next



Exit Sub

10:

MsgBox "Tutar aktarıldı."

End Sub
Kilitli
  • Benzer Konular
    Cevaplar
    Görüntüleme
    Son mesaj