- Katılım
- 6 Mart 2024
- Mesajlar
- 291
- Excel Vers. ve Dili
- 2010 TR & 2016 TR
Sayfanızda ki TÜM Veri Doğrulaması listelerini Çoklu Seçim e dönüştürür.
Veri Doğrulamaların bulunduğu sayfanın SAYFA İSMİni sağ tıklayıp - Kod Görüntüle tıklayınız - Açılan Pencereye Kodları yapıştırınız
Sayfayı kapatırken Macro İçerebilen Excel Çalışma Kitabı (*.xlsm) olarak kaydedin
- Veri listesinde her bir seçimi aralara virgül koyarak ekler [ A, B, C ]
- Önceden seçilen bir veri yeniden seçilirse, tekrar seçilen veri silinir.
- Verilerinizin bulunduğu listeye "Temizle" veya "Clear" eklerseniz bunlar seçildiğin de veriler temizlenir.
C++:
Option Explicit
' Original: https://stackoverflow.com/questions/50539722/multiselect-in-excel-using-macros-how-to-un-select-the-selection
' Revised by Biolight 2024 - Eppur Si Muove
Private Sub Worksheet_Change(ByVal Target As Range)
' Eski ve yeni değerleri saklamak için değişkenler
Dim Oldvalue As String
Dim Newvalue As String
' Etkinliklerin açık olduğundan emin olun
Application.EnableEvents = True
' Hata oluşursa Exitsub etiketine atla
On Error GoTo Exitsub
' Hücrede Veri Doğrulama olup olmadığını kontrol et
If Not Application.Intersect(Target, Me.Cells.SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
''''''''''''''''''''
' Veri Doğrulama listesinin
' En altına "Temizle" veya "Clear" diye bir veri konulursa
''''''''''''''''''''
' "Temizle" veya "Clear" seçeneği kontrolü
If Target.Value = "Temizle" Or Target.Value = "Clear" Then
Application.EnableEvents = False
Target.Value = "" ' Hücreyi temizle
GoTo Exitsub
End If
' Hücrede değer var mı kontrol et
If Target.Value = "" Then
GoTo Exitsub ' Eğer değer boşsa çık
Else
' Etkinlikleri kapat
Application.EnableEvents = False
' Yeni değeri al
Newvalue = Target.Value
' Son yapılan değişikliği geri al
Application.Undo
' Geri alınan değeri eski değer olarak ayarla
Oldvalue = Target.Value
' Eğer eski değer boşsa, yeni değeri ayarla
If Oldvalue = "" Then
Target.Value = Newvalue
Else
' Eğer eski değerde yeni değer bulunmuyorsa, eski ve yeni değeri birleştir
If InStr(1, Oldvalue, Newvalue) = 0 Then
Target.Value = Newvalue & ", " & Oldvalue
Else
' Eğer yeni değer eski değerde bulunuyorsa, ilk değer olarak belirle
Dim values() As String
Dim result As String
Dim i As Integer
values = Split(Oldvalue, ", ")
result = Newvalue
For i = LBound(values) To UBound(values)
If values(i) <> Newvalue Then
result = result & ", " & values(i)
End If
Next i
' tekrar seçilen değer en başa geldi, en baştaki değeri yok ediyoruz
Target.Value = Replace(result, Newvalue & ", ", "")
End If
End If
End If
End If
Exitsub:
' Etkinlikleri tekrar aç
Application.EnableEvents = True
End SubVeri Doğrulamaların bulunduğu sayfanın SAYFA İSMİni sağ tıklayıp - Kod Görüntüle tıklayınız - Açılan Pencereye Kodları yapıştırınız
Sayfayı kapatırken Macro İçerebilen Excel Çalışma Kitabı (*.xlsm) olarak kaydedin
Son düzenleme:
