sayfa2 deki satırı hücre değerine göre sayfa1 e çekme

[torino]

Merhaba,
3 sayfalı bir çalışma kitabım var. Birinci sayfamın adı UYGULAMA BİLGİLERİ, ikinci sayfamın adı SENARYOLAR(bu sayfa gizli), üçüncü sayfamın adı TEST. Uygulama bilgileri sayfamda bir dizi checkbox ve command button bulunuyor.
Uygulama bilgileri sayfamdaki checkbox1 işaretli ise command buttona tıkladığımda SENARYOLAR sayfasında "C" sütunu değeri "X" olan satırlar TEST sayfasına atansın istiyorum.

 

[Ömer]

SENARYOLAR sayfasında "C" sütunu değeri "X" olan satırlar TEST sayfasına atansın istiyorum.

Merhaba,

Sorunuzun bu kısmını anlayamadım.

Aşağıdaki bir yapı ile, CheckBox1 'in seçili olup olmadığını kontrol edip yazdırabilirsiniz.
Kodlarda CheckBox1 seçili ise Test C1 hücresine, Senaryolar A1 değeri yazılır.

Private Sub CommandButton1_Click()
    
    If CheckBox1.Value = True Then
        Sheets("TEST").Range("C1") = Sheets("SENARYOLAR").Range("A1")
    End If
    
End Sub

.

 

[torino]

Merhaba,

Sorunuzun bu kısmını anlayamadım.

Aşağıdaki bir yapı ile, CheckBox1 'in seçili olup olmadığını kontrol edip yazdırabilirsiniz.
Kodlarda CheckBox1 seçili ise Test C1 hücresine, Senaryolar A1 değeri yazılır.

Private Sub CommandButton1_Click()
    
    If CheckBox1.Value = True Then
        Sheets("TEST").Range("C1") = Sheets("SENARYOLAR").Range("A1")
    End If
    
End Sub

.

Şöyle açıklayayım.
-UYGULAMA BİLGİLERİ sayfasındaki checkbox1 işaretliyken command button tıklandığında, SENARYOLAR sayfasındaki C sütununda ABC yazan satırlar TEST sayfasına kopyalanacak.
-UYGULAMA BİLGİLERİ sayfasındaki checkbox2 işaretliyken command button tıklandığında, SENARYOLAR sayfasındaki D sütununda DEF yazan satırlar TEST sayfasına kopyalanacak.

gibi

 

[Ömer]

İstediğiniz bu değilse daha detaylı açıklama yapmanızı rica ederim.

Private Sub CommandButton1_Click()

    Dim Ss As Worksheet, St As Worksheet, c As Range, Adr As String
    Dim deg(), alan(), a As Byte, b As Byte, sat As Long

    Set Ss = Sheets("SENARYOLAR")
    Set St = Sheets("TEST")
    
    deg = Array("ABC", "DEF")
    alan = Array("C", "D")
    
    b = 0
    If CheckBox2.Value = True Then
        a = 1: b = 1
    End If
    If CheckBox1.Value = True Then
        a = 0: b = 1
    End If
    If b = 0 Then Exit Sub
    
    Application.ScreenUpdating = False
    St.Rows("2:" & Rows.Count).ClearContents

    sat = 2
    Set c = Ss.Columns(alan(a)).Find(deg(a), , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            Ss.Rows(c.Row).Copy St.Cells(sat, "A")
            sat = sat + 1
            Set c = Ss.Columns(alan(a)).FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If

End Sub

Not: Checkbox1 ve Checkbox2'nin aynı anda işaretli olması durumunda aktarım önceliğini Checkbox1'e verdim.

.

 

[torino]

hocam uyarlamaya çalıştım ama yapamadım. Size detay vereyim.
Senaryolar sheetinde c sütununun değeri TCP,USB yada TÜMÜ olabilir. checkbox1 işaretli ise TCP olan satırlar, checkbox2 işaretli ise USB olan satırlar TEST sayfasına kopyalanacak. İkisi de işaretliyse hepsi kopyalanacak.

Yine senaryolar sheetinde d sütununun değeri TOPLU yada AYRIK olabilir. checkbox3 işaretliyse TOPLU, checkbox4 işaretliyse AYRIK olanlar TEST sayfasına kopyalanacak.

Ama checkbox1 ve checkbox3 işaretliyse checkbox3 dikkate alınmalı. Yani checkbox4 işaretli değilse c sütun değeri TCP olmasına rağmen süttun değeri AYRIK olan satırlar kopyalanmamalı

 

[Ömer]

İstediğiniz bu mu?

Private Sub CommandButton1_Click()

    Dim Ss As Worksheet, St As Worksheet, c As Range, Adr As String
    Dim deg(), alan(), sat As Long, i As Byte, nesne As Object, s As Byte, dizi()

    Set Ss = Sheets("SENARYOLAR")
    Set St = Sheets("TEST")
    
    deg = Array("TCP", "USB", "TOPLU", "AYRIK") '[COLOR="Green"]aranan değerler[/COLOR]
    alan = Array("C", "C", "D", "D") '[COLOR="green"]değerlerin hangi sütunda aranacağı[/COLOR]
    
    Application.ScreenUpdating = False
    St.Rows("2:" & Rows.Count).ClearContents
  
    For Each nesne In Sheets("UYGULAMA BİLGİLERİ").OLEObjects
        If TypeName(nesne.Object) = "CheckBox" Then
            If nesne.Object.Value = True Then
                ReDim Preserve dizi(s)
                dizi(s) = Replace(nesne.Name, "CheckBox", "")
                s = s + 1
            End If
        End If
    Next
    If s = 0 Then Exit Sub
    
    sat = 2
    For i = 0 To UBound(dizi)
        Set c = Ss.Columns(alan(dizi(i) - 1)).Find(deg(dizi(i) - 1), , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                Ss.Rows(c.Row).Copy St.Cells(sat, "A")
                sat = sat + 1
                Set c = Ss.Columns(alan(dizi(i) - 1)).FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i

End Sub

.

 

[torino]

Buna subscript out of range hatası verdi

 

[Ömer]

Sorularınızı örnek dosya ile destekleyip detaylı açıklama yapmanızı rica ederim.

Linki inceleyin.
İstediğiniz bu değil mi?

http://s4.dosya.tc/server5/f40a37/Kitap1.rar.html

.