CheckBox Seçili İse Aynı verileri Başka Hücreye Yazdırma

[ormann]

Günaydın ekteki örnekte c5:c7 hücrelerindeki verilerin aynısını c14:c16 hücrelerine nasıl yazdırabiliriz?

 

[Necdet]

Günaydın ekteki örnekte c5:c7 hücrelerindeki verilerin aynısını c14:c16 hücrelerine nasıl yazdırabiliriz?

• C5:C7 yi seçersiniz
• Sağ Klik, Kopyala
• C14 ü seçersiniz
• Sağ Klik, Yapıştır
• İşlem Tamamdır

Sanırım excele yeni başladınız ki soruyu excele yeni başlayanlar bölümünde sordunuz.

 

[ormann]

Sayın Nejdet bey CheckBox'u seçtiğimiz zaman otamatik olarak ilgili hücrelerdeki verilerin otamatik olarak kopyalanmasını demiştim

 

[Necdet]

Sayın Nejdet bey CheckBox'u seçtiğimiz zaman otamatik olarak ilgili hücrelerdeki verilerin otamatik olarak kopyalanmasını demiştim

Merhaba,

1. Adım Necdet, Nejdet değil
2. Konuyu makro bölümünde açmalıydınız.

Yine de kodları vereyim, sonra konuyu makro bölümüne taşıyım.

Private Sub CheckBox1_Click()
    If CheckBox1.Value = True Then Range("C5:C7").Copy Range("C14")
End Sub

 

[ormann]

Sayın Necdet bey çok teşekkür ederim.Acaba işareti kaldırdığımız zaman kopyalanan veriler silinebilir mi?

 

[Necdet]

Sayın Necdet bey çok teşekkür ederim.Acaba işareti kaldırdığımız zaman kopyalanan veriler silinebilir mi?

Neden olmasın, onu da yaparsınız diye düşünüyorum. Yapamazsanız şöyle olacak :

Private Sub CheckBox1_Click()
    If CheckBox1.Value = True Then
        Range("C5:C7").Copy Range("C14")
    Else
        Range("C14:C16").ClearContents
    End If
End Sub

Tabii bunu ilk soruda sorsaydınız fazladan yazışmalara neden olunmazdı.

 

[ormann]

Çok teşekkür ederim.Ellerinize sağlık

 

[sahika51]

Neden olmasın, onu da yaparsınız diye düşünüyorum. Yapamazsanız şöyle olacak :

Private Sub CheckBox1_Click()
    If CheckBox1.Value = True Then
        Range("C5:C7").Copy Range("C14")
    Else
        Range("C14:C16").ClearContents
    End If
End Sub

Tabii bunu ilk soruda sorsaydınız fazladan yazışmalara neden olunmazdı.

Necdet bey bir çalışma yapıyordum araştırma yaparken bu kod gördüm benimde işime yaradı teşekkür ederim.
Ancak benim çalışmam biraz daha farklı bu yapılabilir mi bilmiyorum yardımcı olursanız sevinirim.
1- Kişilere isim ve bilgi girdikçe kişinin yanına otomatik checkBox oluşması
2-CheckBox işaretleme yapınca işaretli olan checkBox satırındaki bilgilerin Liste çalışma sayfasındaki tabloya aktarılması
3-İşaret kalktığında Liste çalışma sayfasındaki satırın silinerek sıralamanın yeniden oluşması

 

[Necdet]

Merhaba,

Son günlerde çok tembelim, pek sık ta gelmiyorum foruma. O yüzden kodların çoğunu ben CHATGPT'ye yazdırdım.
Aşağıdaki kodları kisiler sayfasının kod bölümüne kopyalayınız.

kisiler sayfasının B sütununda bir değişiklik olduğunda A sütununa CheckBox Ekler.
A sütununu font rengini beyaz yaparsanız checkbox a tıklandığında evet/hayır ları görmezsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
'Kodlar ChatGPT den 
    Dim chkBox As CheckBox
    Dim cell As Range
    Dim chkBoxName As String
    
    ' Sadece B sütununda veri girildiğinde işlemi başlat
    If Not Intersect(Target, Me.Columns("B")) Is Nothing And Target.Row > 1 Then
        ' Hedef aralıktaki her hücre için
        For Each cell In Target
            ' Eğer hücre boş değilse
            If cell.Value <> "" Then
                ' CheckBox'un adını satır numarasına göre belirle
                chkBoxName = "chkBox_" & cell.Row
                
                ' Eğer o satırda CheckBox yoksa ekle
                On Error Resume Next
                Set chkBox = Me.CheckBoxes(chkBoxName)
                On Error GoTo 0
                
                If chkBox Is Nothing Then
                    ' CheckBox ekleyelim ve hücrenin A sütununa yerleştirelim
                    Set chkBox = Me.CheckBoxes.Add(cell.Offset(0, -1).Left, cell.Offset(0, -1).Top, cell.Offset(0, -1).Width, cell.Offset(0, -1).Height)
                    With chkBox
                        .Caption = "" ' Checkbox üzerindeki yazıyı kaldır
                        .LinkedCell = cell.Offset(0, -1).Address ' Checkbox durumunu A hücresine bağla
                        .Name = chkBoxName ' Checkbox ismini satır numarasına göre ver
                        .OnAction = "CheckBoxClicked" ' CheckBox'a makro atama
                    End With
                End If
                
                ' Temizleme
                Set chkBox = Nothing
            End If
        Next cell
    End If
End Sub

Aşağıdaki kodları da bir modül açarak oraya kopyalayabilirsiniz.

Sub CheckBoxClicked()
                                'ChatGPT kodları
    Dim chkBoxName As String
    Dim chkBox As CheckBox
    Dim chkState As String
    Dim r As Long
    
    ' Tıklanan CheckBox'ın adını almak
    chkBoxName = Application.Caller
    
    ' Tıklanan CheckBox'ı Set etmek
    Set chkBox = ActiveSheet.CheckBoxes(chkBoxName)
    
    ' CheckBox'ın durumunu öğrenmek
    If chkBox.Value = xlOn Then
        chkState = "Açık"
    Else
        chkState = "Kapalı"
    End If
    
    ' Mesaj kutusunda CheckBox'ın adını ve durumunu göster
'    MsgBox "Tıklanan CheckBox: " & chkBoxName & vbCrLf & "Durumu: " & chkState
    r = CLng(Split(chkBoxName, "_")(1))   'Tıklanan CheckBoxın adından numarasını/satır no öğrenmek

    If chkState = "Açık" Then
        Liste_Sayfasina_Aktar r
    ElseIf chkState = "Kapalı" Then
        Liste_Sayfasindan_Sil r
    End If
    
End Sub


Public Sub Liste_Sayfasina_Aktar(ByRef r As Long)

    Dim lr  As Long
    lr = Sayfa2.Cells(Rows.Count, "B").End(3).Row + 1
    Sayfa1.Range("A" & r & ":G" & r).Copy Sayfa2.Range("A" & lr)
    
End Sub

Public Sub Liste_Sayfasindan_Sil(ByRef r As Long)

    Dim lr  As Long
    Dim c   As Range
    Dim evt As String
    
    Set c = Sayfa2.Range("C:C").Find(Sayfa1.Range("C" & r), LookIn:=xlValues)
    
    If Not c Is Nothing Then
        lr = c.Row
        evt = MsgBox("Liste Sayfasında " & c.Row & ". SATIRI SİLİNECEK, EMİN MİSİNİZ?", vbYesNo)
        If evt = vbYes Then
            Sayfa2.Rows(c.Row).Delete
            MsgBox "Liste Sayfasındaki " & lr & " satırı silinmiştir...."
        Else
            MsgBox "SİLMEKTEN VAZGEÇTİNİZ....."
        End If
    End If
    
End Sub

 

[sahika51]

Merhaba,

Son günlerde çok tembelim, pek sık ta gelmiyorum foruma. O yüzden kodların çoğunu ben CHATGPT'ye yazdırdım.
Aşağıdaki kodları kisiler sayfasının kod bölümüne kopyalayınız.

kisiler sayfasının B sütununda bir değişiklik olduğunda A sütununa CheckBox Ekler.
A sütununu font rengini beyaz yaparsanız checkbox a tıklandığında evet/hayır ları görmezsiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
'Kodlar ChatGPT den
    Dim chkBox As CheckBox
    Dim cell As Range
    Dim chkBoxName As String
   
    ' Sadece B sütununda veri girildiğinde işlemi başlat
    If Not Intersect(Target, Me.Columns("B")) Is Nothing And Target.Row > 1 Then
        ' Hedef aralıktaki her hücre için
        For Each cell In Target
            ' Eğer hücre boş değilse
            If cell.Value <> "" Then
                ' CheckBox'un adını satır numarasına göre belirle
                chkBoxName = "chkBox_" & cell.Row
               
                ' Eğer o satırda CheckBox yoksa ekle
                On Error Resume Next
                Set chkBox = Me.CheckBoxes(chkBoxName)
                On Error GoTo 0
               
                If chkBox Is Nothing Then
                    ' CheckBox ekleyelim ve hücrenin A sütununa yerleştirelim
                    Set chkBox = Me.CheckBoxes.Add(cell.Offset(0, -1).Left, cell.Offset(0, -1).Top, cell.Offset(0, -1).Width, cell.Offset(0, -1).Height)
                    With chkBox
                        .Caption = "" ' Checkbox üzerindeki yazıyı kaldır
                        .LinkedCell = cell.Offset(0, -1).Address ' Checkbox durumunu A hücresine bağla
                        .Name = chkBoxName ' Checkbox ismini satır numarasına göre ver
                        .OnAction = "CheckBoxClicked" ' CheckBox'a makro atama
                    End With
                End If
               
                ' Temizleme
                Set chkBox = Nothing
            End If
        Next cell
    End If
End Sub

Aşağıdaki kodları da bir modül açarak oraya kopyalayabilirsiniz.

Sub CheckBoxClicked()
                                'ChatGPT kodları
    Dim chkBoxName As String
    Dim chkBox As CheckBox
    Dim chkState As String
    Dim r As Long
   
    ' Tıklanan CheckBox'ın adını almak
    chkBoxName = Application.Caller
   
    ' Tıklanan CheckBox'ı Set etmek
    Set chkBox = ActiveSheet.CheckBoxes(chkBoxName)
   
    ' CheckBox'ın durumunu öğrenmek
    If chkBox.Value = xlOn Then
        chkState = "Açık"
    Else
        chkState = "Kapalı"
    End If
   
    ' Mesaj kutusunda CheckBox'ın adını ve durumunu göster
'    MsgBox "Tıklanan CheckBox: " & chkBoxName & vbCrLf & "Durumu: " & chkState
    r = CLng(Split(chkBoxName, "_")(1))   'Tıklanan CheckBoxın adından numarasını/satır no öğrenmek

    If chkState = "Açık" Then
        Liste_Sayfasina_Aktar r
    ElseIf chkState = "Kapalı" Then
        Liste_Sayfasindan_Sil r
    End If
   
End Sub


Public Sub Liste_Sayfasina_Aktar(ByRef r As Long)

    Dim lr  As Long
    lr = Sayfa2.Cells(Rows.Count, "B").End(3).Row + 1
    Sayfa1.Range("A" & r & ":G" & r).Copy Sayfa2.Range("A" & lr)
   
End Sub

Public Sub Liste_Sayfasindan_Sil(ByRef r As Long)

    Dim lr  As Long
    Dim c   As Range
    Dim evt As String
   
    Set c = Sayfa2.Range("C:C").Find(Sayfa1.Range("C" & r), LookIn:=xlValues)
   
    If Not c Is Nothing Then
        lr = c.Row
        evt = MsgBox("Liste Sayfasında " & c.Row & ". SATIRI SİLİNECEK, EMİN MİSİNİZ?", vbYesNo)
        If evt = vbYes Then
            Sayfa2.Rows(c.Row).Delete
            MsgBox "Liste Sayfasındaki " & lr & " satırı silinmiştir...."
        Else
            MsgBox "SİLMEKTEN VAZGEÇTİNİZ....."
        End If
    End If
   
End Sub

Necdet bey süpersiniz valla teşekkür ederim

 

[Necdet]

Merhaba,
güle güle kullanınız.