• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Checkbox, Sütunlara veri aktramak

  • Konbuyu başlatan Konbuyu başlatan okreg
  • Başlangıç tarihi Başlangıç tarihi
O

okreg

Katılım
5 Kasım 2006
Mesajlar
31
Excel Vers. ve Dili
2002, Türkçe
Merhaba

Sayfa2'de bulunan A ve B sütunlarındaki veriler sabit.

C sütununa ise -5 ile 10 arasında değerler girilecek

Yapmak istediğim;
Checkbox'ı seçili olan hücrelerdeki tanım ve sıra bilgilerini, Aktar butonuna basınca sıra numarasına göre Sayfa1'e aktarmak

Yardımcı olacaklara şimdiden teşekkürler
 

Ekli dosyalar

okreg' Alıntı:
Merhaba

Sayfa2'de bulunan A ve B sütunlarındaki veriler sabit.

C sütununa ise -5 ile 10 arasında değerler girilecek

Yapmak istediğim;
Checkbox'ı seçili olan hücrelerdeki tanım ve sıra bilgilerini, Aktar butonuna basınca sıra numarasına göre Sayfa1'e aktarmak

Yardımcı olacaklara şimdiden teşekkürler
Genişletmek için tıkla ...

Selam,

Sayfa2'nin kod sayfasına aşağıdaki kodları kopyalayıp, sayfanızdaki aktar tuşuna basarak deneyiniz.
İyi çalışmalar.

Kod: 
Private Sub CommandButton1_Click()
Dim s1, s2 As Worksheet

Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")

s1.Range("B1:IV256").ClearContents

sut = 1
For i = 1 To 20
Set cb = ActiveSheet.OLEObjects(i)
If Left(cb.Name, 8) = "CheckBox" Then

If cb.Object = True Then
sut = sut + 1

s1.Cells(2, sut) = s2.Cells(i + 1, "B")
s1.Cells(1, sut) = s2.Cells(i + 1, "C")

End If
End If
Next

MsgBox "Aktarma İşlemi Tamamlanmıştır", vbInformation
End Sub
 
alternatif kod




Private Sub CommandButton1_Click()
sut = 2
Sheets("Sayfa1").Range("B1:IV2").ClearContents
Dim Picture As Object
For Each Picture In ActiveSheet.Shapes
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEForma t.Object) = "OLEObject" Then
If TypeName(ActiveSheet.Shapes(Picture.Name).OLEForma t.Object.Object) = "CheckBox" Then
If ActiveSheet.Shapes(Picture.Name).OLEFormat.Object. Object = True Then
sat = Picture.BottomRightCell.Row
Sheets("Sayfa1").Cells(1, sut).Value = Sheets("Sayfa2").Cells(sat, 3).Value
Sheets("Sayfa1").Cells(2, sut).Value = Sheets("Sayfa2").Cells(sat, 2).Value
sut = sut + 1
End If
End If
End If
Next Picture
End Sub
Genişletmek için tıkla ...
 
Sn Ergün Güler ve Halit3

ilginize teşekkürler fakat sıralama ölçütü sıra no üzerinden olacak
yani;

ilk sütunda -2. sıra ve Tanım2
2. sütunda -1. sıra ve Tanım1
3. sütunda -1. sıra ve Tanım12
.....
13.sütunda 7. sıra ve Tanım9

şeklinde

devam edecek..

Birde şunu farkettim. copy - paste komutu ile aktarmam gerekiyor.
Çünkü kopyaladığım veri bir link ile başka bir çalışma sayfasına yönleniyor. Aktarma yaptığımda link içeriği ile birlikte kopyalanmalı
 
Son düzenleme:
Sanırım aynı kodda istediğim olmuyor..

Peki aktarma yaptıktan sonra sıralama yapmak istesem nasıl yaparım

Sıralama ölçütü 1. satırdaki veriler olacak. Tabi 2. satırdaki veriler. 1. satır sıralamasına göre değişmiş olacak.

Ek'te gönderdim

Teşekkürler
 

Ekli dosyalar

okreg' Alıntı:
yardımcı olabilecek yokmudur?
Genişletmek için tıkla ...
Sayın okreg,
son gönderdiğiniz dosyada sadece "sayfa1" var. listeniz nereye aktarılacak?

ilk gönderdiğiniz örnek dosyanızın "sayfa2" kod sayfasına aşağıdaki kodları uygulayarak deneyiniz.

Kod: 
Private Sub CommandButton1_Click()
Dim s1, s2 As Worksheet

Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")

s1.Range("B1:IV256").ClearContents
s1.Range("IU:IV").ClearContents

say = 1
sat = 0

Application.ScreenUpdating = False

For i = 1 To s2.OLEObjects.Count
If Left(s2.OLEObjects(i).Name, 8) = "CheckBox" Then

say = say + 1

If s2.OLEObjects(i).Object = True Then
sat = sat + 1

s1.Cells(sat, "IV") = s2.Cells(say, "B")
s1.Cells(sat, "IU") = s2.Cells(say, "C")

End If

End If
Next

s1.Range("IU:IV").Sort Key1:=s1.Range("IU1"), Order1:=xlAscending, Key2:=s1.Range("IV1"), Order2:=xlAscending

son = s1.Range("IV65536").End(3).Row

For j = 1 To son

s1.Cells(1, 1 + j) = s1.Cells(j, "IU")
s1.Cells(2, 1 + j) = s1.Cells(j, "IV")

Next

s1.Range("IU:IV").ClearContents

Application.ScreenUpdating = True
MsgBox "Aktarma ve Sıralama İşlemi Tamamlanmıştır", vbInformation
End Sub
 
Son düzenleme:
okreg' Alıntı:
Sn Ergün Güler

İhtiyaç ihtiyacı doğuruyor. Acaba aktarılacak hücredeki ifadeye link tanımlanmışsa, hücredeki tanımı link içeriği ile birlikte aktarabilirmiyiz.
Ek iliştirdim..

Teşekkürler
Genişletmek için tıkla ...

Selam,
Aşağıdaki kodları dener misiniz?

Kod: 
Private Sub CommandButton1_Click()

Dim s1, s2 As Worksheet

Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")

s1.Range("B1:IV256").ClearContents
s1.Range("IU:IV").ClearContents

say = 1
sat = 0

Application.ScreenUpdating = False

For i = 1 To s2.OLEObjects.Count
If Left(s2.OLEObjects(i).Name, 8) = "CheckBox" Then

say = say + 1

If s2.OLEObjects(i).Object = True Then
sat = sat + 1

s2.Cells(say, "B").Copy
s1.Cells(sat, "IV").PasteSpecial
s2.Cells(say, "C").Copy
s1.Cells(sat, "IU").PasteSpecial

End If

End If
Next

s1.Range("IU:IV").Sort Key1:=s1.Range("IU1"), Order1:=xlAscending, Key2:=s1.Range("IV1"), Order2:=xlAscending

son = s1.Range("IV65536").End(3).Row

For j = 1 To son

s1.Cells(j, "IU").Copy
s1.Cells(1, 1 + j).PasteSpecial
s1.Cells(j, "IV").Copy
s1.Cells(2, 1 + j).PasteSpecial

Next

s1.Range("IU:IV").ClearContents

Application.ScreenUpdating = True
MsgBox "Aktarma ve Sıralama İşlemi Tamamlanmıştır", vbInformation


End Sub
 
Ergün Güler' Alıntı:
Selam,
Aşağıdaki kodları dener misiniz?

Kod: 
Private Sub CommandButton1_Click()

Dim s1, s2 As Worksheet

Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")

s1.Range("B1:IV256").ClearContents
s1.Range("IU:IV").ClearContents

say = 1
sat = 0

Application.ScreenUpdating = False

For i = 1 To s2.OLEObjects.Count
If Left(s2.OLEObjects(i).Name, 8) = "CheckBox" Then

say = say + 1

If s2.OLEObjects(i).Object = True Then
sat = sat + 1

s2.Cells(say, "B").Copy
s1.Cells(sat, "IV").PasteSpecial
s2.Cells(say, "C").Copy
s1.Cells(sat, "IU").PasteSpecial

End If

End If
Next

s1.Range("IU:IV").Sort Key1:=s1.Range("IU1"), Order1:=xlAscending, Key2:=s1.Range("IV1"), Order2:=xlAscending

son = s1.Range("IV65536").End(3).Row

For j = 1 To son

s1.Cells(j, "IU").Copy
s1.Cells(1, 1 + j).PasteSpecial
s1.Cells(j, "IV").Copy
s1.Cells(2, 1 + j).PasteSpecial

Next

s1.Range("IU:IV").ClearContents

Application.ScreenUpdating = True
MsgBox "Aktarma ve Sıralama İşlemi Tamamlanmıştır", vbInformation


End Sub
Genişletmek için tıkla ...


Sn. Ergün Güler
Çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst