- Katılım
- 14 Kasım 2013
- Mesajlar
- 2
- Excel Vers. ve Dili
- 2010 ingilizce
Merhabalar, excel programında vba ile kodlama yaparak çalıştırmak istediğim ufak bir programım var. Programda 1 tek şey hariç herşey düzgün çalışıyor. Çalışmayan ise; textbox ile filtreleme yaptığımda filtrelenen sütunda değer yoksa hata veriyor. Hata veren komut ise
"Application.Goto Reference:=Range(x.address), scroll:=False"
Kodların tamamını ekliyorum. Yardımcı olursanız çok sevinirim. Teşekkürler.
"Application.Goto Reference:=Range(x.address), scroll:=False"
Kodların tamamını ekliyorum. Yardımcı olursanız çok sevinirim. Teşekkürler.
Kod:
Private Sub ComboBox5_Change()
End Sub
Private Sub ComboBox1_Change()
ComboBox3.Value = "": ComboBox2.Value = ""
If ComboBox1.Text <> "" Then
Call baglan
ComboBox2.Column = con.Execute("select [İLÇELER] from [Sayfa3$] where [İLLER]='" & ComboBox1.Text & "' group by [İLÇELER]").getrows
Set con = Nothing
Else
ComboBox2.Clear: ComboBox3.Clear
End If
End Sub
Private Sub ComboBox2_Change()
ComboBox3.Text = ""
If ComboBox2.Text <> "" Then
Call baglan
ComboBox3.Column = con.Execute("select [ÇALIŞANLAR] from [Sayfa3$] where [İLLER]='" & ComboBox1.Text & "'" & _
" and [İLÇELER]='" & ComboBox2.Text & "'").getrows
Set con = Nothing
Else
ComboBox3.Clear
End If
End Sub
Private Sub ComboBox3_Change()
ComboBox4.Text = ""
If ComboBox3.Text <> "" Then
Call baglan
ComboBox4.Column = con.Execute("select [ÇALIŞANLAR] from [Sayfa3$] where [İLLER]='" & ComboBox1.Text & "'" & _
" and [İLÇELER]='" & ComboBox2.Text & "'").getrows
Set con = Nothing
Else
ComboBox3.Clear
End If
End Sub
Private Sub ComboBox4_Change()
End Sub
Private Sub ComboBox6_Change()
End Sub
Private Sub CommandButton1_Click()
If SatirSayisiVer > 1 Then
MsgBox "Filtrelenen veriye göre benzersiz kayıt bulunamadı!"
ElseIf SatirSayisiVer = 1 Then
MsgBox "Veri Yaz"
Kaydet
ElseIf SatirSayisiVer = 0 Then
MsgBox "Filtrelenen veriye göre hiçbir kayıt bulunamadı!"
ElseIf SatirSayisiVer = -1 Then
MsgBox "-1"
End If
End Sub
Private Sub DTPicker21_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)
End Sub
Private Sub TextBox1_Change()
TextBox1.MaxLength = 6
SadeceSayi TextBox1
Filtrele
End Sub
Sub SadeceSayi(obj)
Dim i As Integer
Dim str As String
If TypeName(obj) = "TextBox" Then
With obj
For i = 1 To Len(obj.Text)
str = Mid(.Text, i, 1)
If Not IsNumeric(str) And .Value <> vbNullString Then
.Text = Mid(obj.Text, 1, i - 1) & Mid(obj.Text, i + 1)
MsgBox "Sadece Sayı Giriniz"
End If
Next
End With
End If
End Sub
Function Filtrele()
ActiveCellDegistir IlkHucreBul
Selection.AutoFilter Field:=9, Criteria1:="*" & TextBox1.Value & "*"
If TextBox1.Value = "" Then
Selection.AutoFilter Field:=9
End If
End Function
Function SatirSayisiVer() As Integer
Range("a1").Select
Selection.CurrentRegion.Select
row_count = Selection.Rows.Count - 3
matched_criteria = 0
check_row = 0
Filtrele
While Not IsEmpty(ActiveCell)
ActiveCell.Offset(1, 0).Select
If ActiveCell.RowHeight = 0 Then
check_row = check_row + 1
Else
matched_criteria = matched_criteria + 1
End If
Wend
ActiveCellDegistir IlkHucreBul
If row_count = check_row Then
SatirSayisiVer = -1
Else
SatirSayisiVer = matched_criteria
End If
End Function
Function IlkHucreBul() As Range
Dim aboneNo As String
Dim ilkhucre As Range
On Error Resume Next
'aboneNo = (TextBox1.Value * 1)
aboneNo = TextBox1.Value
Set ilkhucre = Range("I3: I65000 ").Find(What:=aboneNo)
Set IlkHucreBul = ilkhucre
End Function
Function ActiveCellDegistir(ilkhucre As Range)
Application.Goto Reference:=Range(ilkhucre.Address), Scroll:=False
End Function
Function Kaydet()
Dim activeSatir As Integer
activeSatir = ActiveCell.Row
Range("B" & activeSatir).Value = ComboBox1.Value
Range("C" & activeSatir).Value = ComboBox2.Value
End Function