hücredeki değere göre makro butonu çalıştırma

[Schuba]

arkadaşlar şöyle bir makro butonuna ihtiyacım var yardımcı olursanız sevinirim

sayfa 1 de makroyu çalıştırmak için bir butonum var istediğim şey
makro butonuna tıkladığım zaman

sayfa 1 deki (a1) hücresinde eğer ahmet yazıyorsa

sayfa 1 deki (a3 ile g3) hücreleri arasındaki verileri kopyalıyıp
sayfa 2 deki (a3 ile g3) arasındaki hücrelere yapıştırsın

yok eğer
sayfa 1 deki (a1) hücresinde mehmet yazıyorsa bu seferde

sayfa 1 deki (a3 ile g3) hücreleri arasındaki verileri yine aynı şekilde kopyalayıp bu sefer hem

sayfa 2 deki (a3 ile g3) arasındaki hücrelere yapıştırsın hemde
sayfa 3 deki (a3 ile g3) arasındaki hücrelere yapıştırsın

örnek dosyayı ekledim yapıp yollıyacak arkadaşa şimdiden teşekkür ederim..

 

[vardar07]

Modül'e ekleyip deneyiniz.

Sub YuvarlatılmışDikdörtgen_Tıklat()
If Sayfa1.Cells(1, 1) = "AHMET" Then
Sayfa1.Range("A3:G3").Copy Sayfa2.Range("A3")
ElseIf Sayfa1.Cells(1, 1) = "MEHMET" Then
Sayfa1.Range("A3:G3").Copy Sayfa2.Range("A3")
Sayfa1.Range("A3:G3").Copy Sayfa3.Range("A3")
End If
End Sub

 

[Schuba]

HOCAM GÖNDERDİĞİNİZ KOD GAYET GÜZEL ÇALIŞIYOR TEŞEKKÜR EDERİM FAKAT BEN BU KODU MEVCUT OLAN BİR KODUMUN BAŞINDA KULLANMAK İÇİN SİZDEN İSTEMİŞTİM FAKAT MEVCUT KODUMA ENTEGRE EDEMEDİM
MEVCUT KODUM KOD BÖLÜMÜNDE YAZIYOR
BENİM İSTEDİĞİM BU MEVCUT KODUMUN BUTONA TIKLADIĞIM ZAMAN BUTONUN BULUNDUĞU SAYFANIN (G2) HÜCRESİNİN DEĞERİNE GÖRE KAYDETMESİ YANİ (G2) HÜCRESİNDE ÖRNEĞİN AHMET YAZIYORSA SADECE SAYFA 1 E MEHMET YAZIYORSA HEM SAYFA 1 E HEMDE SAYFA 2 YE KAYDETSİN AMA SİZE GÖNDERDİĞİM KODDA SADECE SAYFA 1 E KAYDEDİYOR
SİZ BANA SADECE AHMET YAZDIĞIMDA VE SONRA BUTONA BASTIĞIM ZAMAN SAYFA 1 KAYDETMESİNİ SAĞLAYIN
YANİ BUTONUN MEVCUT OLAN KODUMUN (G2) HÜCRESİNDEKİ DEĞERE GÖRE ÇALIŞMASINI SAĞLARSANIZ GERİSİNİ BEN HALLEDERİM

SAYGILAR....

Sub YENİKAYITKAYDET()
'
' YENİKAYITKAYDET Makro
'

'
Dim hücre As Range
If WorksheetFunction.CountBlank(Range("D13")) > 0 Or WorksheetFunction.CountBlank(Range("D16")) > 0 _
Or WorksheetFunction.CountBlank(Range("D18")) > 0 Or WorksheetFunction.CountBlank(Range("D22")) > 0 _
    Or WorksheetFunction.CountBlank(Range("D28")) > 0 Then
    MsgBox "LÜTFEN VERİ GİRİŞİ'NİN ZORUNLU OLDUĞU ALANLARI DOLDURUNUZ!", vbCritical
    For Each hücre In Range("D13, D16, D18, D22, D28")
        If hücre = "" Then
            hücre.Select
            GoTo 10
        End If
    Next
Else
Sheets("BAKIM TAKİP").Select
    ActiveSheet.Unprotect "1122"
    Application.Calculation = xlManual
    Selection.AutoFilter
    Range("B24").Select
Sheets("MAKRO KOPYALAMA").Select
    Range("D47:U47").Select
    Selection.Copy
yeni = Sheets("BAKIM TAKİP").Cells(Rows.Count, "C").End(3).Row + 1
    Sheets("BAKIM TAKİP").Cells(yeni, "C").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks:=True_
    Application.CutCopyMode = False
    Sheets("BAKIM TAKİP").Select
    Range("B25:T25").Select
    Selection.AutoFilter
    Application.Calculation = xlAutomatic
    ActiveSheet.Protect "1122", DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowInsertingHyperlinks:=True, _
        AllowFiltering:=True, AllowUsingPivotTables:=True
    Range("B24").Select
End If
10:
End Sub