• DİKKAT

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

Birbiri ile çalışmayan iki kod nasıl birleştirilir ?

T

TURKPLUS

Katılım
30 Ocak 2013
Mesajlar
14
Excel Vers. ve Dili
2010 INGILIZCE
Değerli Arkadaşlar

bir çalışma için, D sütununda bir hücrede onay verildiğinde hemen yanındaki C sütunundaki açılır menü içeren (listbox/textbox) bu onayla ilgili başka hücrenin kilitlenmesini sağlamak için bir kod uyguladık. Bu kodla dosya iyi çalıştı.

Fakat açılır menü içinde kişileri araraken uzun liste içinde aramayı kolaylaştırmak için autocomplete özelliğini uygulamak mümkün mü diye araştırdık. Bir uzman arkadaşın katkısıyla listbox için autocomplete özelliği uygulanmaz uyarısıyla, listbox'u autocomplete özelliğini destekleyen comboboxa dönüştürmek için yeni bir kod ekledik. Ancak bu kod ilk kodla birleştirilince ilk kod çalışmaz yani hücre kilitlenmez oldu. Nasıl düzeltebileceğimi ise bulamadım. Yardımcı olur musunuz?

(Uygulanan Kodlar aşağıda ve örnek dosyalar ekte)

Teşekkürler




1. dosyadaki kod şöyle:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [c8:g100]) Is Nothing Then Exit Sub
ActiveSheet.Unprotect
Range("c8:g100").Locked = False
For sat = 8 To 100
If Cells(sat, "d") = "TEYID ALINDI" Then
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = True
Else
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = False
End If
If Cells(sat, "f") = "TEYID ALINDI" Then
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = True
Else
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = False
End If
Next
ActiveSheet.Protect
End Sub



1. kod ile birleştirilen 2. kod ise şöyle:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [c8:g100]) Is Nothing Then
ActiveSheet.Unprotect
Else
ActiveSheet.Unprotect
Range("c8:g100").Locked = False
For sat = 8 To 100
If Cells(sat, "d") = "TEYID ALINDI" Then
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = True
Else
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = False
End If
If Cells(sat, "f") = "TEYID ALINDI" Then
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = True
Else
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = False
End If
Next
Call sel_change
'ActiveSheet.Protect
End If

End Sub


Private Sub TempCombo_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
'Combobox'i sakla, enter,tab ile cik
Select Case KeyCode
Case 9
ActiveCell.Offset(0, 1).Activate
Case 13
ActiveCell.Offset(1, 0).Activate
Case Else
'bos
End Select

End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim metin As String
Dim Tempcombo As OLEObject
Dim sayfa As Worksheet
Dim sayfaListesi As Worksheet
Set sayfa = ActiveSheet
Set sayfaListesi = Sheets("PERSONEL")
Cancel = True
Set Tempcombo = sayfa.OLEObjects("TempCombo")
On Error Resume Next
With Tempcombo
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo Hata_tutucu
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
metin = Target.Validation.Formula1
metin = Right(metin, Len(metin) - 1)
With Tempcombo
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height + 5
.ListFillRange = metin
.LinkedCell = Target.Address
End With
Tempcombo.Activate
End If

Hata_tutucu:
Application.EnableEvents = True
Exit Sub

End Sub

Sub sel_change()
Dim metin As String
Dim Tempcombo As OLEObject
Dim sayfa As Worksheet
Set sayfa = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = False

If Application.CutCopyMode Then
'Sayfa uzerinde kopyala yapistir yapabilmek icin
GoTo Hata_tutucu
End If

Set Tempcombo = sayfa.OLEObjects("TempCombo")
On Error Resume Next
With Tempcombo
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With

Hata_tutucu:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub

End Sub
 

Ekli dosyalar

UZMAN ARKADAŞLAR: Birbiri ile çalışmayan iki kod nasıl birleştirilir ?

Aşağıdaki konuda yardımcı olabilecek, Uzman Üstad Arkadaşların desteğine ihtiyacım var...Teşekkürler
 
TURKPLUS' Alıntı:
Değerli Arkadaşlar

bir çalışma için, D sütununda bir hücrede onay verildiğinde hemen yanındaki C sütunundaki açılır menü içeren (listbox/textbox) bu onayla ilgili başka hücrenin kilitlenmesini sağlamak için bir kod uyguladık. Bu kodla dosya iyi çalıştı.

Fakat açılır menü içinde kişileri araraken uzun liste içinde aramayı kolaylaştırmak için autocomplete özelliğini uygulamak mümkün mü diye araştırdık. Bir uzman arkadaşın katkısıyla listbox için autocomplete özelliği uygulanmaz uyarısıyla, listbox'u autocomplete özelliğini destekleyen comboboxa dönüştürmek için yeni bir kod ekledik. Ancak bu kod ilk kodla birleştirilince ilk kod çalışmaz yani hücre kilitlenmez oldu. Nasıl düzeltebileceğimi ise bulamadım. Yardımcı olur musunuz?

(Uygulanan Kodlar aşağıda ve örnek dosyalar ekte)

Teşekkürler




1. dosyadaki kod şöyle:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [c8:g100]) Is Nothing Then Exit Sub
ActiveSheet.Unprotect
Range("c8:g100").Locked = False
For sat = 8 To 100
If Cells(sat, "d") = "TEYID ALINDI" Then
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = True
Else
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = False
End If
If Cells(sat, "f") = "TEYID ALINDI" Then
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = True
Else
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = False
End If
Next
ActiveSheet.Protect
End Sub



1. kod ile birleştirilen 2. kod ise şöyle:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, [c8:g100]) Is Nothing Then
ActiveSheet.Unprotect
Else
ActiveSheet.Unprotect
Range("c8:g100").Locked = False
For sat = 8 To 100
If Cells(sat, "d") = "TEYID ALINDI" Then
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = True
Else
Range(Cells(sat, "c"), Cells(sat, "d")).Locked = False
End If
If Cells(sat, "f") = "TEYID ALINDI" Then
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = True
Else
Range(Cells(sat, "e"), Cells(sat, "f")).Locked = False
End If
Next
Call sel_change
'ActiveSheet.Protect
End If

End Sub


Private Sub TempCombo_KeyDown(ByVal _
KeyCode As MSForms.ReturnInteger, _
ByVal Shift As Integer)
'Combobox'i sakla, enter,tab ile cik
Select Case KeyCode
Case 9
ActiveCell.Offset(0, 1).Activate
Case 13
ActiveCell.Offset(1, 0).Activate
Case Else
'bos
End Select

End Sub


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim metin As String
Dim Tempcombo As OLEObject
Dim sayfa As Worksheet
Dim sayfaListesi As Worksheet
Set sayfa = ActiveSheet
Set sayfaListesi = Sheets("PERSONEL")
Cancel = True
Set Tempcombo = sayfa.OLEObjects("TempCombo")
On Error Resume Next
With Tempcombo
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
On Error GoTo Hata_tutucu
If Target.Validation.Type = 3 Then
Application.EnableEvents = False
metin = Target.Validation.Formula1
metin = Right(metin, Len(metin) - 1)
With Tempcombo
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 15
.Height = Target.Height + 5
.ListFillRange = metin
.LinkedCell = Target.Address
End With
Tempcombo.Activate
End If

Hata_tutucu:
Application.EnableEvents = True
Exit Sub

End Sub

Sub sel_change()
Dim metin As String
Dim Tempcombo As OLEObject
Dim sayfa As Worksheet
Set sayfa = ActiveSheet
Application.EnableEvents = False
Application.ScreenUpdating = False

If Application.CutCopyMode Then
'Sayfa uzerinde kopyala yapistir yapabilmek icin
GoTo Hata_tutucu
End If

Set Tempcombo = sayfa.OLEObjects("TempCombo")
On Error Resume Next
With Tempcombo
.Top = 10
.Left = 10
.Width = 0
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
.Value = ""
End With

Hata_tutucu:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub

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




:!: Bu konuda destek olabilecek uzman bir arkadaşımız var mıdır? :!:
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst