Bir sütundaki hücrelere makro atama

[Schuba]

Arkadaşlar şöyle birşey yapmak istiyorum örneğin bir sayfanın (B1 ile B1000) arasındaki hücrelerine makro atamak istiyorum ve bu hücrelerden herhangi birini tıkladığımda makro çalışarak gidip hemen yanındaki (A SUTUNDAN) tıkladığım hücrenin aynı satırındaki hücrenin değerini kopyalayıp başka bir sayfadaki (A1) hücresine yapıştırmasını istiyorum..

Not: bu arada bunu niye yapacaksın diye sorarsanız benim bir müşteri listem var ( A sütununda) cari kodları var ( B sütununda) müşteri isimleri var
başka bir sayfadada bu müşteri listesini toparlayan bir form şeklinde tablo var
benim istediğim müşteri ismini tıkladığımda yanındaki cari kodunu alıp form şeklindeki diyer sayfamın A1 Hücresine kopyaladığı zaman benim hazırladığım bu form o cari kodunu referans olarak alıp listedeki bilgileri çekecek.

 

[Korhan Ayhan]

Aşağıdaki kodu ilgili sayfanın kod bölümüne uygulayın.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("B1:B10000")) Is Nothing Then Exit Sub
    Sheets("Sayfa2").Range("A1") = Target.Offset(0, -1).Value
End Sub

 

[Schuba]

Hocam çok sağolun göndediğiniz kod gayet güzel çalışıyor fakat tıkladıktan sonra (sayfa 2) açılmıyor. Yani tıkladığımda işlem yapılıyor fakat hücre değerinin yapıştırılacağı (a1) hücresinin bulunduğu (sayfa 2) açılmıyor ekranda aynı sayfa kalıyor. Ben tıkladıktan sonra işlem yapılıp (sayfa 2) nin açılmasını istiyorum.
Birde sizden ricam hani hücreye tıkladığımızda makro çalışıyor ya çift tıkladığımızda çalısın istiyorum çünkü bağzen istemeden tıklıya biliyoruz..

 

[Asri]

@Korhan Ayhan ın kodunda değişiklik yapıldı.
Bu şekilde deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("B1:B10000")) Is Nothing Then Exit Sub
    Sheets("Sayfa2").Range("A1") = Target.Offset(0, -1).Value
    Sheets("Sayfa2").Select
End Sub

 

[Schuba]

Hocam aklınıza sağlık süper oldu..teşekür ederim..

 

[Schuba]

Hocam bu koda ilave olarak işlem yapıldıktan sonra imleçin (A2) hücresinde durmasını istiyorum yardımcı olursanız çok sevinirim

 

[Asri]

Bu şekilde deneyiniz.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("B1:B10000")) Is Nothing Then Exit Sub
    Sheets("Sayfa2").Range("A1") = Target.Offset(0, -1).Value
    Sheets("Sayfa2").Select
    Sheets("Sayfa2").Range("A2").Select
End Sub

 

[Schuba]

Hocam yardımlarınız için çok sağolun çok işe yaradı sizden bir isteğim daha olacak yardımcı olursanız sevinirim

Benim bir müşteri sayfam var 10000 satır kadar bu müşterileri gözden geçirirken göz yanılması olabiliyor bir satıra bakarken diğer satırla karıştıra biliyorum
Benim istediğim hangi satırın üstüne tıklarsam o satırın açık mavi veya bu programlarda olduğu gibi gölge şeklinde hafif gıri olarak tıkladığım satırın rengi değişsin tabi başka bir satıra tıkladığım zamanda önce tıkladığım satır eski halini alsın yeni satır busefer aynı işlemi yapsın
Yanlız bir ricamda bu tıkladığım satırın tamamı boydan boya reng değiştirmesin Belli bir aralıkta olsun
örneğin B20 de başlasın H20 de bitsin
ayrıca yukardan aşağıda 20 inci satırdan başlasın 10000 inci satırda bitsin

 

[Korhan Ayhan]

Sayfanızın kod bölümüne uygulayıp deneyiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Range("B20:H10000").Interior.Color = xlNone
    If Intersect(Target, Range("B20:H10000")) Is Nothing Then Exit Sub
    Range("B" & Target.Row & ":H" & Target.Row).Interior.Color = 11711154
End Sub

 

[Schuba]

hocam gönderdiğiiz kod çok güzel çalışıyor elerinze sağlık
yanlız sizden bi ricam olacak hani tıkladığımız satır gırıye boyanıyo ya bu gıri rengi çok koyu olmuş yazılarda siyah olduğ için okuması biraz zor oluyor bu gıri rengini çok açık bir gıri rengine dönüştüre bilirmiyiz
örneğin. hani excell sayfasında herhangi bir hücre aralığını seçtiğimiz zaman gölge şeklinde açık gıri bir reng oluşuyor ya öyle olsun istiyorum olursa çok sevinirim...

 

[Asri]

hocam gönderdiğiiz kod çok güzel çalışıyor elerinze sağlık
yanlız sizden bi ricam olacak hani tıkladığımız satır gırıye boyanıyo ya bu gıri rengi çok koyu olmuş yazılarda siyah olduğ için okuması biraz zor oluyor bu gıri rengini çok açık bir gıri rengine dönüştüre bilirmiyiz
örneğin. hani excell sayfasında herhangi bir hücre aralığını seçtiğimiz zaman gölge şeklinde açık gıri bir reng oluşuyor ya öyle olsun istiyorum olursa çok sevinirim...

Aşağıdaki şekilde deneyiniz.

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
   Range("B20:H10000").Interior.Color = xlNone  
   If Intersect(Target, Range("B20:H10000")) Is Nothing Then Exit Sub 
   Range("B" & Target.Row & ":H" & Target.Row).Interior.Color = 16772300 
End Sub

 

[Schuba]

hocam sizden bir ricam daha olucak aşağdaki kodları aynı sayfanın kod bölümüne yazıyorum üç kod birarada çalışmıyor
biri hata veriyor birinci kodla üçüncü kod birarada çalışıyor aynı şekilde ikinci kodla üçüncü kodda beraber çalışıyor
ama birinci kodla ikinci kod bir aradayken çalışmıyor aynı şekilde üçü biraradaykende çalışmıyor
bu üç kodun birarada çalıçacak bir şekilde bana düzenlerseniz çok sevinirim saygılar......



Private Sub Worksheet_BeforeDOUBLEClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("E24:E30000")) Is Nothing Then Exit Sub
Sheets("MÜŞTERİ CARİSİ").Range("D5") = Target.Offset(0, -3).Value
Sheets("MÜŞTERİ CARİSİ").Select
Sheets("MÜŞTERİ CARİSİ").Range("B20").Select
End Sub


Private Sub Worksheet_BeforeDOUBLEClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("B24:B30000")) Is Nothing Then Exit Sub
Sheets("FİŞ KAPAMA FORMU").Range("H15") = Target.Offset(0).Value
Sheets("FİŞ KAPAMA FORMU").Select
Sheets("FİŞ KAPAMA FORMU").Range("H24").Select
End Sub


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Range("B24:T30000").Interior.Color = xlNone
If Intersect(Target, Range("B24:T30000")) Is Nothing Then Exit Sub
Range("B" & Target.Row & ":T" & Target.Row).Interior.Color = 16772300
End Sub

 

[Schuba]

Uyarı penceresi

Hocam cok acil yardımınıza ihtiyacım var yardım konusu ekli dosyada mevcuttur bir bakarsanız çok sevinirim iyi çaalışmalar

 

[YUSUF44]

İlk isteğiniz için KAYDET makrosunu aşağıdakiyle değiştirip deneyiniz. Makro veri girilen alanlarda boşluk varsa uyarı verir ve boş hücreyi seçer:

Sub KAYDET()
Dim hücre As Range
If WorksheetFunction.CountBlank(Range("C3")) > 0 Or WorksheetFunction.CountBlank(Range("C5:C11")) > 0 _
    Or WorksheetFunction.CountBlank(Range("C13:C19")) > 0 Then
    MsgBox "Lütfen Eksik Olan Bilgileri Doldurunuz", vbCritical
    For Each hücre In Range("C3, C5:C11, C13:C19")
        If hücre = "" Then
            hücre.Select
            GoTo 10
        End If
    Next
Else
    Sheets("FORMÜL ALANI").Select
    Range("A3:O3").Select
    Selection.Copy
    Sheets("MÜŞTERİ LİSTESİ").Select
    Application.Goto Reference:="R1000C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=-21
    Range("A2").Select
End If
10:
End Sub

 

[YUSUF44]

Yalnız dosyanızda ilginç ve hatta gereksiz olduğunu düşündüğüm bir durum var: Neden önce Formül alanı sayfasına formülle veri çekip sonra da onları Müşteri Listesi sayfasına aktarmaya çalışıyorsunuz ki? Bunun yerine verileri doğrudan Müşteri Listesi Sayfasına aktarabilirsiniz. Sonuçta ha A sayfasından veri aktarmışsınız ha B sayfasından. İkisi de aynı şey.

 

[YUSUF44]

Tek seferde yapmak isterseniz Kayıt Formu sayfasındaki boş satırları (4 ve 12 idi galiba) silin ve Kaydet makrosunu aşağıdakiyle değiştirin. Makro boş hücre varsa uyarı verip hücreyi seçer, yoksa verileri liste sayfasındaki ilk boş satıra değer olarak yapıştırır:

Sub KAYDET()
Dim hücre As Range
If WorksheetFunction.CountBlank(Range("C3:C17")) > 0 Then
    MsgBox "Lütfen Eksik Olan Bilgileri Doldurunuz", vbCritical
    For Each hücre In Range("C3:C17")
        If hücre = "" Then
            hücre.Select
            GoTo 10
        End If
    Next
Else
    yeni = Sheets("MÜŞTERİ LİSTESİ").Cells(Rows.Count, "A").End(3).Row + 1
    Sheets("KAYIT FORMU").[C3:C17].Copy: Sheets("MÜŞTERİ LİSTESİ").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Range("C3").Select
    Application.CutCopyMode = False
End If
10:
End Sub

 

[Schuba]

Hocam doğru söylüyosunuzda ben kod yazmasını bilmiyorum dolayısıyla müşteri listesine aktarılması gereken bilgilerin hangisinin nereye yapıştırmasni kod olarak yazamiyorum o yüzden bende formül alanı sayfasının bir satırını aynı müşteri listesi gibi ayarladim ve forma girdiğimde verileri önce formül alanı sayfasında müşteri listesinin alanı gibi toparlayıp daha sonra kaydet butonuna makro atayarak yani kaydetme yöntemiyle formül alanı bilgilerini alıp müşteri listesi sayfasına değerleri yapiştiriyorum

Ayrıca bilgisayarın başına oturup gönderdiğiniz kodları deniyemdim daha bu arada hızlı geri dönüşünü için teşekkür ederim ...
Kodları dosyama uyguladıktan sonra tekrar geri dönüş yaparım. Saygılar,........

 

[YUSUF44]

Aslında çok küçük bir uğraşla kendiniz de yapabilirsiniz. Şöyle ki excelde makro kaydet özelliği var. Bu özelliği başlattığınızda Excel yaptığınız her şeyi makro kodlarıyla kaydeder. Siz de bu kodlardan yola çıkarak kendi makronuzu geliştirebilirsiniz.

Benim verdiğim kodla önceki kod arasındaki kopyala yapıştır olarak tek fark benim kodlarım yapıştırmayı "işlemi tersine çevir" yöntemiyle yapıyor. Fareyle verileri seçip, kopyalayıp, hedefe gidip, sağ tıklayıp, özel yapıştır seçip, işlemi tersine çevir denilerek yapılan işlemi tek satırda yapan bir kod benimki. Bunu yapabilmeyi daha 2 hafta önce öğrendim.

Biraz uğraşarak siz de kendinizi geliştirebilirsiniz.

 

[Schuba]

Hocam kodlarınızı denedim işe yarıyor ama 2 inci gönderdiğiniz kod form sayfasındaki c4 ve c12 hücrelerinide baz alıyor ve makro sona erdiğinde form sayfasında kalıyor ilk kod 2 inciye nazaran daha iyi

ayrıca formül alanı sayfasını dediğiniz gibi kullanmamak için kodda bazı değişiklikler yaptım iyi oldu gibi sizde isterseniz bir bakın daha kısa yoldan yapacak bir kod varsa beklerim..



Sub KAYDET()
Dim hücre As Range
If WorksheetFunction.CountBlank(Range("C3")) > 0 Or WorksheetFunction.CountBlank(Range("C5:C11")) > 0 _
Or WorksheetFunction.CountBlank(Range("C13:C19")) > 0 Then
MsgBox "Lütfen Eksik Olan Bilgileri Doldurunuz", vbCritical
For Each hücre In Range("C3, C5:C11, C13:C19")
If hücre = "" Then
hücre.Select
GoTo 10
End If
Next
Else
Sheets("KAYIT FORMU").Select
Range("C3, C5:C11, C13:C19").Select
Selection.Copy
Sheets("MÜŞTERİ LİSTESİ").Select
yeni = Sheets("MÜŞTERİ LİSTESİ").Cells(Rows.Count, "A").End(3).Row + 1
Sheets("KAYIT FORMU").[C3, C5:C11, C13:C19].Copy: Sheets("MÜŞTERİ LİSTESİ").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
Range("A2").Select
Application.CutCopyMode = False
End If
10:
End Sub

 

[YUSUF44]

İlk kod da ikinci kod da düzgün olarak çalışıyor aslında. İkinci kodla ilgili olarak daha önce boş olan 4. ve 12. satırları silmeniz gerektiğini belirtmiştim. Yani arada boş satırlar olmamalıydı. Böylece tek seferde veriler aktarılabiliyor. Denemelerimde sorunsuz olarak çalıştı.

Aktarma işleminden sonra Müşteri listesi sayfasına geçmek istiyorsanız aşağıdaki gibi kullanmalısınız:

Sub KAYDET()
Dim hücre As Range
If WorksheetFunction.CountBlank(Range("C3:C17")) > 0 Then
    MsgBox "Lütfen Eksik Olan Bilgileri Doldurunuz", vbCritical
    For Each hücre In Range("C3:C17")
        If hücre = "" Then
            hücre.Select
            GoTo 10
        End If
    Next
Else
    yeni = Sheets("MÜŞTERİ LİSTESİ").Cells(Rows.Count, "A").End(3).Row + 1
    Sheets("KAYIT FORMU").[C3:C17].Copy: Sheets("MÜŞTERİ LİSTESİ").Cells(yeni, "A").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Range("C3").Select
    Application.CutCopyMode = False
[B][COLOR="Red"]    Sheets("MÜŞTERİ LİSTESİ").Select
    Cells(yeni, "A").Select[/COLOR][/B]
End If
10:
End Sub