Koşullu Kopyala Yapıştır

[mehce]

Örnek dosyayı ekledim Üstadların yardımını rica ediyorum dosyada açıkladım ama kısaca 4 hücre var alt alta bunları kopyalayıp a1 hücresinin değerine göre aynı sayfada başka bir hücreye "sadece değerleri yapıştırmak" istiyorum eğer ve copy yi nasıl birleştireceğiz şimdiden teşekkürler.

 

[acolkesen1]

Merhaba,
Sub kopyala()
If [a1] = [w4] Then
[m5:m8].Copy
[w5].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
[w8].Select
End Sub
Diğer şartlar için de uyarlayarak kullanabilirsiniz. İyi çalışmalar.

 

[Korhan Ayhan]

Selamlar,

Sayfanın kod bölümüne aşağıdaki kodu uygulayıp denermisiniz.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim X As Byte
    On Error GoTo Son
    If Intersect(Target, [A1]) Is Nothing Then Exit Sub
    For X = 23 To 35
        If Cells(4, X) = Range("A1") Then
        Application.EnableEvents = False
        Range(Cells(5, X), Cells(8, X)).Value = Range("M5:M8").Value
        Application.EnableEvents = True
        Exit For
        End If
    Next
Son:
Application.EnableEvents = True
End Sub

 

[Ömer]

Merhaba,

Alternatif olsun. Çalışma sayfası kod bölümüne kopyalayın.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
    Set c = Range("W4:AI4").Find(Range("A1"), LookIn:=xlValues)
    If Not c Is Nothing Then
        Range("M5:M8").Copy Cells(5, c.Column)
    End If
End Sub

.

 

[mehce]

Selamlar,

Sayfanın kod bölümüne aşağıdaki kodu uygulayıp denermisiniz.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim X As Byte
    On Error GoTo Son
    If Intersect(Target, [A1]) Is Nothing Then Exit Sub
    For X = 23 To 35
        If Cells(4, X) = Range("A1") Then
        Application.EnableEvents = False
        Range(Cells(5, X), Cells(8, X)).Value = Range("M5:M8").Value
        Application.EnableEvents = True
        Exit For
        End If
    Next
Son:
Application.EnableEvents = True
End Sub

Cahilliğimi mazur görün kod bölümü derken nereyi kastetdiğinizi anlayamadım.Tarif edebilirmisiniz

 

[Ömer]

Çalışma sayfa adı üzerine fare ile sağ clik yaparak "Kod Görüntüle" seçeneğini işaretledikten sonra bir sayfa açılır kodları bu bölüme kopyalayın.

.

 

[mehce]

Galiba this workbook kısmına kasdediyorsunuz ama bu kodu ne ile çalıştıracağım bir düğmeye bağlamayacakmıyız?

 

[Ömer]

ThisWorkbook değil yukarıda açıkladığım gibi sayfanın kod bölümüne.

A1 hücresindeki veri doğrulamayı değiştirdikçe kod çalışacaktır.

.

 

[mehce]

Ömer hocam teşekkürler evet kod çalışıyor ama ben bir düğmeye bağlayıp makro gibi çalıştırmayı düşünmüştüm bir kere yapıştırma yapıldımı hücreler değişmeyecek esasen bunlar gelir vergisi matrahı her ayınkini üstüne koyarak vergi dilimlerine girdiğinde otomatik gelir vergisi hesabı yapmak için gerekliydi.

 

[Ömer]

Module kopyalarak butona bağlayın.

Sub Kopyala()
Dim c As Range
Set c = Range("W4:AI4").Find(Range("A1"), LookIn:=xlValues)
If Not c Is Nothing Then
    Range("M5:M8").Copy Cells(5, c.Column)
End If
End Sub

.

 

[mehce]

Module kopyalarak butona bağlayın.

Sub Kopyala()
Dim c As Range
Set c = Range("W4:AI4").Find(Range("A1"), LookIn:=xlValues)
If Not c Is Nothing Then
    Range("M5:M8").Copy Cells(5, c.Column)
End If
End Sub

.

Çalışmıyor Ömer Hocam

 

[mehce]

Merhaba,
Sub kopyala()
If [a1] = [w4] Then
[m5:m8].Copy
[w5].PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
[w8].Select
End Sub
Diğer şartlar için de uyarlayarak kullanabilirsiniz. İyi çalışmalar.

Sizin kodda çalışmıyor üstadım

 

[mehce]

Çok özür dilerim gayet güzel çalışıyor bi hata yapmışım
Her ikinizdende çok özür diliyorum elleriniz dert görmesin

 

[acolkesen1]

Tekrar merhaba,
Ekteki dosyayı inceleyin. Ben denedim, a1 ve w4 deki değerlere göre çalışıyor. Diğerlerini de siz yaparsınız diye düşünmüştüm.

 

[acolkesen1]

Önemli değil, işe yaradıysa ne mutlu.. İyi çalışmalar.

 

[Ömer]

Çalışmıyor Ömer Hocam

Çalışmadığını söylediğiniz dosyayı eklerseniz neden çalışmadığını açıklama fırsatımız olur.

Eki inceleyin.

.

 

[mehce]

Çalışmadığını söylediğiniz dosyayı eklerseniz neden çalışmadığını açıklama fırsatımız olur.

Eki inceleyin.

.

Ömer Hocam 3 mesaj üstteki özrümü kabul edin lütfen çok teşekkürler benim hatam çalışıyor kodlarınız.

 

[Ömer]

Sayın mehce,

Özürlük bir durum yok. Söylemek istediğim, hatanın nedenini tahmini olarak değilde net bir şekilde size yorumlayabilmek için hata aldığınız dosyayı incelemek gerekir.

Ayrıca dosyada veri alınan bölümde formül olduğu için son eklediğim dosyadaki kodları kullanmanız daha doğru olacaktır.

İyi çalışmalar..

.

 

[mehce]

Tekrar teşekkür ederim çalışan formülünüze çalışmıyor dediğim için özür diledim. İyi çalışmalar