Makro ile seçili tikteki sekmeyi düşey ara yapma

[iaslan517]

Merhabalar, ekte belirttiğim gibi seçili olan tik hangisi ise o sekmede düşey ara yaptıran program yazabilmemiz mümkün mü

 

[Ömer]

Merhaba,

Kodların başına ilave edin.

Dim syf As String
syf = ""
If ActiveSheet.Shapes("Check Box 2").ControlFormat.Value = 1 Then
    syf = "Sayfa2"
End If
If ActiveSheet.Shapes("Check Box 3").ControlFormat.Value = 1 Then
    syf = "Sayfa3"
End If
If syf = "" Then
    Range("B:B").ClearContents
    MsgBox "sayfa seçilmemiş"
    Exit Sub
End If

Ayrıca;

Set s2 = Sheets("Sayfa2")

yukarıdaki satırın yerine aşağıdaki satırı yazın.

Set s2 = Sheets(syf)


.

 

[iaslan517]

ömer hocam çok teşekkür ederim. Sizden ricam bu işlem G H I sütundaki verileri kopyalamak içinde kullanılabilir mi? ekte örneğini verdim bu konudada yardımcı olabilirmisiniz. Ana verilerde B sütununda olacak

 

[Ömer]

Aynı tabloyu eklemişsiniz.

.

 

[iaslan517]

Aynı tabloyu eklemişsiniz.

.

Ömer Hocam Kusuruma bakmayın. Dosyayı şimdi ekledim.

 

[Ömer]

Bu şekilde deneyin.

Private Sub CommandButton1_Click()

    Dim syf As String, S2 As Worksheet, i As Long, c As Range
    
    Set S2 = Sheets("Sayfa2")
    
    syf = ""
    If ActiveSheet.Shapes("Check Box 2").ControlFormat.Value = 1 Then
        syf = "Sayfa2"
    End If
    If ActiveSheet.Shapes("Check Box 3").ControlFormat.Value = 1 Then
        syf = "Sayfa3"
    End If
    If syf = "" Then
        Range("G:I").Clear
        MsgBox "sayfa seçilmemiş"
        Exit Sub
    End If
    
    Range("G:I").Clear
    For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
        Set c = Sheets(syf).[B:B].Cells.Find(Cells(i, "B"), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Sheets(syf).Cells(c.Row, "G").Resize(1, 3).Copy Cells(i, "G")
        End If
    Next i

End Sub

.

 

[iaslan517]

Çok Teşekkür ederim Ömer Hocam başarılarınızın devamını diliyorum