Onay İşareti İle İşlem Yapmak

[ormann]

İyi günler ekteki dosyada seç sayfasında listedeki onay işretlerinin herhangi birini seçtiğimde ekler sayfasında e18 hücresinden sırasıyla başlayarak işretli olanların karşısındaki kelimeleri ekteki örnekler gibi ekler sayfasına yazdırabilirmiyiz?

 

[ormann]

Arkadaşlar rica etsem yardımcı olabilirsiniz

 

[ormann]

Arkadaşlar yardımcı olabilir misiniz ?

 

[halit3]

kod:

Sub aktar()

sat = 18
Set s1 = Sheets("seç")
Set s2 = Sheets("ekler")
s2.Range("e18:e38").ClearContents

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Object = True Then
satir = s1.Shapes(Picture.Name).BottomRightCell.Row
deg = s1.Cells(satir, 2).Value

s2.Cells(sat, "e").Value = s1.Cells(satir, "c").Value & "(" & s1.Cells(satir, "d").Value & " Adet)"
sat = sat + 1

End If
End If
End If
Next Picture

MsgBox "İşlem tamam", vbInformation, "U Y A R I"
End Sub

 

[ormann]

Halit Bey çok teşekkür ederim.Yardımlarınız için
aklıma sonradan birşey geldi .Kod şu şekilde düzenlenebilirmi ?.
Aktarılan kısmın önüne sıra numarası verilebilir mi?
1-A (1 Adet)
2-b(3 Adet)
3-c(4 adet)

 

[halit3]

Bunu kendinizde yapabilirsiniz.

 

[ormann]

Halit Bey beceremedim.Rica etsem siz yapabilirmisiniz ?

 

[halit3]

kod:

Sub aktar()

sat = 18
Set s1 = Sheets("seç")
Set s2 = Sheets("ekler")
s2.Range("e18:e38").ClearContents

Dim Picture As Object
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "OLEObject" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Object) = "CheckBox" Then
If s1.Shapes(Picture.Name).OLEFormat.Object.Object = True Then
satir = s1.Shapes(Picture.Name).BottomRightCell.Row
deg = s1.Cells(satir, 2).Value
[COLOR="Red"]say = say + 1[/COLOR]
s2.Cells(sat, "e").Value = [COLOR="red"]say & "-" &[/COLOR] s1.Cells(satir, "c").Value & "(" & s1.Cells(satir, "d").Value & " Adet)"
sat = sat + 1

End If
End If
End If
Next Picture

MsgBox "İşlem tamam", vbInformation, "U Y A R I"
End Sub

 

[ormann]

Çok Teşekkür ederim.

 

[halit3]

Çok Teşekkür ederim.

Teşekkürler iyi çalışmalar