Kodun daha hızlı çalışması

[omeryılmaz]

Arkadaşlar Aşağıdaki Kodların daha hızlı çalışabilmesi için nasıl bir düzenleme yapılabilir. Şimdiden emeğiniz için teşekkür ederim...

Private Sub kayit_Click()
On Error Resume Next
Dim aa, i, s, sira, sat
Dim x As Boolean
x = False
For i = 1 To Sheets("sayfa1").Cells(65000, 3).End(xlUp).Row
If ComboBox2.Text = Sheets("sayfa1").Cells(i, 3) And ComboBox3.Text = Sheets("sayfa1").Cells(i, 4) Then
x = True
MsgBox ("Mükerrer kayıt"), , "Bu kayıt daha önce girilmiş."
Exit For
End If
Next i
If x = False Then
aa = WorksheetFunction.CountA(Columns("A"))
If ComboBox1.Value = "" Then
MsgBox ("Desimal Noyu Giriniz.")
Exit Sub
End If
If ComboBox2.Value = "" Then
MsgBox ("Sayısını Giriniz.")
Exit Sub
Else
End If

For s = 1 To 17
Cells(aa + 1, s + 1) = Controls("ComboBox" & s)
Next s
For sira = 1 To aa
Cells(sira + 1, 1) = sira
Next sira
Dim sonsat
sonsat = [A65536].End(3).Row
Cells(sonsat, 17) = CDate(ComboBox16)
ListBox1.Clear
ActiveWorkbook.Save
MsgBox ComboBox2.Text & " numaralı evrak " & ComboBox1.Text & " klasörüne kaydedilmiştir."
ComboBox16 = Format(Date, "dd.mm.yyyy")
End If
End Sub

 

[hsayar]

deneyiniz

Private Sub kayit_Click()
On Error Resume Next
Dim csf As Worksheet: Set csf = Sheets("sayfa1")
Dim aa&, i&, s&, sira&, sat&
Dim x As Boolean
Dim sonsat&
x = False
With csf
  For i = 1 To .Cells(65000, 3).End(xlUp).Row
    If ComboBox2.Text = .Cells(i, 3) And ComboBox3.Text = .Cells(i, 4) Then
      x = True
      MsgBox ("Mükerrer kayıt"), , "Bu kayıt daha önce girilmiş."
      Exit For
    End If
  Next i
  
  If x = False Then
    aa = WorksheetFunction.CountA(Columns("A"))
      If ComboBox1.Value = "" Then
        MsgBox ("Desimal Noyu Giriniz.")
        Exit Sub
      End If
      If ComboBox2.Value = "" Then
        MsgBox ("Sayısını Giriniz.")
        Exit Sub
      End If

      For s = 1 To 17
        .Cells(aa + 1, s + 1) = Controls("ComboBox" & s)
      Next s
      For sira = 1 To aa
        .Cells(sira + 1, 1) = sira
      Next sira
      
      sonsat = .[A65536].End(3).Row
      .Cells(sonsat, 17) = CDate(ComboBox16)
      ListBox1.Clear
    ActiveWorkbook.Save
    MsgBox ComboBox2.Text & " numaralı evrak " & ComboBox1.Text & " klasörüne kaydedilmiştir."
    ComboBox16 = Format(Date, "dd.mm.yyyy")
  End If
end with
Set csf = Nothing
End Sub

 

[Korhan Ayhan]

Selamlar,

Mükerrer kayıt kontrolünü tüm kayıtları döngüye alarak yapmışsınız. C-D sütunlarına göre mükerrer kayıt kontrolü yapıyorsunuz. Döngüleri az hacimli dosyalarda kullanmanızı tavsiye ederim.

Çözüm olarak;

1- C-D sütunlarını sayfa üzerinde birleştirip EĞERSAY ile bu sorguyu yapabilirsiniz.
2- FIND komutunu kullanarak mükerrer kayıt kontrolü yapabilirsiniz.

Farklı çözümlerde üretilebilir.

Bu şekilde kodlarınıza hız kazandırabilirsiniz.

 

[hsayar]

Korhan hocamın dediği yönteme göre bu şekilde olabilir.

Private Sub kayit_Click()
On Error Resume Next
Dim csf As Worksheet: Set csf = Sheets("sayfa1")
Dim aa&, i&, s&, sira&, sat&
Dim x As Boolean, rngbul As Range
Dim sonsat&
x = False
With csf
'  For i = 1 To .Cells(65000, 3).End(xlUp).Row
'    If ComboBox2.Text = .Cells(i, 3) And ComboBox3.Text = .Cells(i, 4) Then
'      x = True
'      MsgBox ("Mükerrer kayıt"), , "Bu kayıt daha önce girilmiş."
'      Exit For
'    End If
'  Next i

  strAra = .Cells(i, 3).Value
[COLOR=Olive]  Set rngbul = .Range("C1:C65000").Cells.Find(strAra, LookIn:=xlValues, LookAt:=xlWhole)             '||
  'If (rngBul Is Nothing) Then
  If rngbul.Row > 0 Then
      If ComboBox2.Text = .Cells(rngbul.Row, 3) And ComboBox3.Text = .Cells(rngbul.Row, 4) Then
      x = True
      MsgBox ("Mükerrer kayıt"), , "Bu kayıt daha önce girilmiş."
      Exit For
    End If
 End If
 Set rngbul = Nothing[/COLOR]



  If x = False Then
    aa = WorksheetFunction.CountA(Columns("A"))
      If ComboBox1.Value = "" Then
        MsgBox ("Desimal Noyu Giriniz.")
        Exit Sub
      End If
      If ComboBox2.Value = "" Then
        MsgBox ("Sayısını Giriniz.")
        Exit Sub
      End If

      For s = 1 To 17
        .Cells(aa + 1, s + 1) = Controls("ComboBox" & s)
      Next s
      For sira = 1 To aa
        .Cells(sira + 1, 1) = sira
      Next sira
      
      sonsat = .[A65536].End(3).Row
      .Cells(sonsat, 17) = CDate(ComboBox16)
      ListBox1.Clear
    ActiveWorkbook.Save
    MsgBox ComboBox2.Text & " numaralı evrak " & ComboBox1.Text & " klasörüne kaydedilmiştir."
    ComboBox16 = Format(Date, "dd.mm.yyyy")
  End If
End With
Set csf = Nothing
End Sub

[/quote]



[/CODE]

 

[hsayar]

kodu denemedim hatalı olmuş, aşağıdaki bloğa benzetiniz:

Sub arabulvs()
Dim csf As Worksheet: Set csf = Worksheets("bayiler")
Dim strAra$, strkrs1$, strkrs2$
With csf
  strAra = "alpata"
  strkrs1 = "alpata"
  Set rngBul = .Range("b1:b65000").Cells.Find(strAra, LookIn:=xlValues, LookAt:=xlWhole)             '||
  If (Not rngBul Is Nothing) Then
    If UCase(rngBul.Value) = UCase(strkrs1) Then
      MsgBox ("Mükerrer kayıt"), , "Bu kayıt daha önce girilmiş."
    End If
  Else
    MsgBox "giriş serbest"
  End If
 Set rngBul = Nothing
End With
End Sub