veri aktarımı

[kesikbey]

Arkadaşlar ekteki dosyada görüleceği gibi seç ile MSH sayfasından aldığım veriyi RAPOR sayfasına aldıktan sonra chec k ile seçilen parselleri aktar butonu ile AKTARILAN SAYFASINA ATIYOR, BU PARSELİ msh SAYFASINDAN SİLİYORUM. Buraya kadar her şey normal. Benim istediğim Chec k butonu ile işaretlemeden AKTAR butonuna tıkladığımda, HİÇ BİR PARSELİ İŞARETLEMEDİNİZ DİYE MESAJ VERSİN
MÜMKÜN OLUR MU ACABA?

 

[kesikbey]

Acaba sorunu mu anlatamadım yoksa çözümsüz mü?

 

[halit3]

Arkadaşlar ekteki dosyada görüleceği gibi seç ile MSH sayfasından aldığım veriyi RAPOR sayfasına aldıktan sonra chec k ile seçilen parselleri aktar butonu ile AKTARILAN SAYFASINA ATIYOR, BU PARSELİ msh SAYFASINDAN SİLİYORUM. Buraya kadar her şey normal. Benim istediğim Chec k butonu ile işaretlemeden AKTAR butonuna tıkladığımda, HİÇ BİR PARSELİ İŞARETLEMEDİNİZ DİYE MESAJ VERSİN
MÜMKÜN OLUR MU ACABA?

Bu kodu denermisiniz eklenen yerler kırmızı ile gösterildi

Sub ÇIK()
Dim k As Range, adr As String
Set s1 = Sheets("RAPOR")
Set s2 = Sheets("RAPOR")
Set s3 = Sheets("AKTARILAN")
sonc = s1.Cells(65000, 1).End(xlUp).Row
sonl = s2.Cells(65000, 2).End(xlUp).Row
sond = s3.Cells(65000, 3).End(xlUp).Row

[COLOR=red]Dim Picture As Object
Dim sat
sat = 0
For Each Picture In s1.Shapes
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object) = "CheckBox" Then
If TypeName(s1.Shapes(Picture.Name).OLEFormat.Object.Value) = "Double" Then ' Long
sat = 1
Exit For
End If
End If
Next Picture[/COLOR]
[COLOR=red]If sat = 0 Then
MsgBox "hiçbir parseli işaratlamadiniz.?"
Exit Sub
End If[/COLOR]
 

For i = 1 To sonc
a = s1.Cells(i, 1)
If s1.Cells(i, 1) = True Then
c = c + 1
s3.Cells(sond + c, 2) = s2.Cells(i, 2)
s3.Cells(sond + c, 3) = s2.Cells(i, 3)
s3.Cells(sond + c, 4) = s2.Cells(i, 4)
s3.Cells(sond + c, 5) = s2.Cells(i, 5)
s3.Cells(sond + c, 6) = s2.Cells(i, 6)
s3.Cells(sond + c, 7) = s2.Cells(i, 7)
s3.Cells(sond + c, 8) = s2.Cells(i, 8)
s3.Cells(sond + c, 9) = s2.Cells(i, 9)
s3.Cells(sond + c, 10) = s2.Cells(i, 10)
s3.Cells(sond + c, 11) = s2.Cells(i, 11)
s3.Cells(sond + c, 12) = s2.Cells(i, 12)
s3.Cells(sond + c, 13) = s2.Cells(i, 13)
s3.Cells(sond + c, 14) = s2.Cells(i, 14)
s3.Cells(sond + c, 15) = s2.Cells(i, 15)
s3.Cells(sond + c, 16) = s2.Cells(i, 16)
s3.Cells(sond + c, 17) = s2.Cells(i, 17)
s3.Cells(sond + c, 18) = s2.Cells(i, 18)
Set k = Sheets("msh").Range("B2:B" & Sheets("msh").Rows.Count) _
.Find(Sheets("RAPOR").Cells(i, "B").Value, , xlValues, xlWhole)
If Not k Is Nothing Then
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Sheets("msh").Range("B" & k.Row & ":O" & k.Row).Delete xlUp
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End If
    
End If
Next
MsgBox "İşlem tamamlandı." & vbLf & "[EMAIL="evrengizlen@hotmail.com"]evrengizlen@hotmail.com[/EMAIL]", vbOKOnly + vbInformation
End Sub

 

[kesikbey]

Arkadaşım çok tşkrler işimi gördü. Selamlar

Yalnız vaktin olursa bir maruzatımı daha gider, check lerden biri işaretli ise SEÇ düğmesi USERFORM açmasın, AKTAR diye ikaz versin. mümkün olabilirse.