- Katılım
- 31 Aralık 2011
- Mesajlar
- 378
- Excel Vers. ve Dili
- 2016 türkçe
- Altın Üyelik Bitiş Tarihi
- 08-10-2020
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
=EĞERHATA(İNDİS($A$3:$A$100;KÜÇÜK(EĞER($C$3:$C$100="Gelir";SATIR($C$3:$C$100)-SATIR($C$3)+1);SATIRSAY(E$2:E2)));"")
=+DÜŞEYARA(E3;A:C;2;0)
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set s1 = Sheets("Kategori Listesi")
sonC = Cells(Rows.Count, "C").End(3).Row
son = s1.Cells(Rows.Count, "C").End(3).Row
If Intersect(Target, Range("D4:D" & sonC)) Is Nothing Then Exit Sub
If Target.Offset(0, -1) <> "" Then
If WorksheetFunction.CountIf(s1.Range("C3:C" & son), Target.Offset(0, -1)) = 0 Then
MsgBox "Önce İşlem türü seçiniz", vbExclamation
Target.Offset(0, -1).Select
Exit Sub
Else
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=NO"""
Application.ScreenUpdating = False
sorgu = "select distinct F1 from[" & s1.Name & "$A3:C" & son & "] where F3='" & Target.Offset(0, -1).Value & "'"
Set rs = con.Execute(sorgu)
ary = Application.Transpose(Application.Transpose(rs.getrows))
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=Join(ary, ",")
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Application.ScreenUpdating = True
End If
End If
End Sub
Bunu şimdi diyorsunuz. Eklediğiniz dosyada ve sorunuzda bundan bahsetmediniz.e4 hücresinde d4 hücresinde seçilen ana kategorinin alt kategorileri görünsün