Makro hızlandırma

[orkuncan5]

Ekteki dosyaya 1000 kadar kayıt girdiğimde arama textboxunda arama yaparken veya kayıt yaperken çok ağır kayıt yapmakta veya arama yapmaktadır.Arama ve kayıt makrosunu daha başka bir metodla hazırlayıp hızlandırmak mümkünmüdür ? Yardımınızı bekliyorum.

 

[halit3]

Ekteki dosyaya 1000 kadar kayıt girdiğimde arama textboxunda arama yaparken veya kayıt yaperken çok ağır kayıt yapmakta veya arama yapmaktadır.Arama ve kayıt makrosunu daha başka bir metodla hazırlayıp hızlandırmak mümkünmüdür ? Yardımınızı bekliyorum.

Dosyadaki veri arttıkca arama birazcık ağırlaşır kayıt yapmak fazla etkilenmez aşağıdaki kodları kullanarak denermisiniz.

Private Sub CommandButton2_Click()
satır = Cells(Rows.Count, "a").End(3).Row + 1
Cells(satır, 1).Value = TextBox2.Value
Cells(satır, 2).Value = TextBox3.Value
Cells(satır, 3).Value = TextBox4.Value
TextBox1.Value = ""
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4.Value = ""
MsgBox "Kayıt Yapıldı"
Call yenile
End Sub
Private Sub ListView1_DblClick()
On Error Resume Next
If Me.ListView1.SelectedItem.ListSubItems(1).Text = "" Then
MsgBox "Seçtiğiniz Bölümde herhangi bir veri bulunmamaktadır..."
Exit Sub
End If
Dim Satir As Integer
'TextBox1.Text = ListView1.SelectedItem
TextBox2.Text = Me.ListView1.SelectedItem.ListSubItems(1).Text
TextBox3.Text = Me.ListView1.SelectedItem.ListSubItems(2).Text
TextBox4.Text = Me.ListView1.SelectedItem.ListSubItems(3).Text
End Sub
Private Sub TextBox1_Change()
ListView1.ListItems.Clear
ad = TextBox1.Text
Set sh = Sheets(ActiveSheet.Name)
sat = 0
x = 0
satır = Cells(Rows.Count, "a").End(3).Row
sutun = 3
If TextBox1 <> "" Then
With sh.Range(Cells(2, 1), Cells(satır, sutun))
Set d = .Find(What:=ad, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
If Val(d.Row) > sat Then
sat = d.Row
x = x + 1
ListView1.ListItems.Add , , d.Row
With ListView1.ListItems(x).ListSubItems
For r = 1 To sutun
.Add , , sh.Cells(d.Row, r)
Next
End With
Else
End If
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With
Set sh = Nothing
Else
Call yenile
End If
End Sub
Private Sub UserForm_Initialize()
satır = Cells(Rows.Count, "a").End(3).Row
sutun = 3
ListView1.ListItems.Clear
ListView1.ColumnHeaders.Clear
ListView1.Gridlines = True
ListView1.View = lvwReport
ListView1.FullRowSelect = True
ListView1.LabelEdit = lvwManual
ListView1.Font.Bold = True
ListView1.ColumnHeaders.Add , , "sıra", 0
For i = 1 To sutun
With ListView1.ColumnHeaders
.Add , , Cells(1, i), Cells(1, i).Width
End With
Next
For j = 2 To satır
x = x + 1
ListView1.ListItems.Add , , x + 1
With ListView1.ListItems(x).ListSubItems
For r = 1 To sutun
.Add , , Cells(j, r)
Next
End With
Next
End Sub
Private Sub yenile()
satır = Cells(Rows.Count, "a").End(3).Row
sutun = 3
ListView1.ListItems.Clear
For j = 2 To satır
x = x + 1
ListView1.ListItems.Add , , x + 1
With ListView1.ListItems(x).ListSubItems
For r = 1 To sutun
.Add , , Cells(j, r)
Next
End With
Next
End Sub

 

[orkuncan5]

Halit Bey Allah razı olsun sizden ,bilgilerinizi ve yardımlarınızı paylaştıkça büyüyorsunuz.

 

[halit3]

Halit Bey Allah razı olsun sizden ,bilgilerinizi ve yardımlarınızı paylaştıkça büyüyorsunuz.

Teşekkürler iyi çalışmalar.