• DİKKAT

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

Makroda yavaşlama

Ö

önder34

Katılım
20 Ekim 2005
Mesajlar
301
Excel Vers. ve Dili
excel 2010 Türkçe
Arkadaşlar buradaki arkadaşların yardımıyla oluşturulan dosyamda aşağıdaki makroyu kullanıyorum 1000 satırdan fazla kayıt yaptık ve devam edecek çok yavaş işlem yapıyor makroda güncelleme ve değişim yapılabilir mi? Ayrıca dosya 2003 de oluşturuldu. Şuan 2007 de kullanıyoruz .Makro aşağıdadır yardımınızı rica ediyorum.

Sub kaydet()
Dim kayit As Integer
Dim xKontrol As String
Dim Bul As Range, ADRES As String
sat = Sheets(2).[A65536].End(3).Row
xKontrol = "boş"
kayit = 0

Set Bul = Sheets("VERİ").Range("C:C").Find(Range("D3"))
If Not Bul Is Nothing Then
ADRES = Bul.Address
Do

Set Bul = Sheets("VERİ").Range("C:C").FindNext(Bul)
Loop While Not Bul Is Nothing And Bul.Address <> ADRES
End If

For i = 2 To sat
If Trim(Sayfa2.Cells(i, 1).Text) = Trim(Sayfa6.Range("D1").Text) And Trim(Sayfa2.Cells(i, 13).Text) = Trim(Sayfa6.Range("D13").Text) Then
xKontrol = "bulundu"
kayit = i
Exit For
End If
Next i

If xKontrol = "boş" Then
kayit = sat + 1
End If
For ix = 1 To 23
Sheets(2).Cells(kayit, ix) = Range("d" & ix)
Next
Call Sayfa2.Birles
End Sub
 
Merhaba
Aşağıdaki gibi denermisiniz?
Kodlarınızdaki "for" döngüsü yerine arama eklendi.
İşaretli bölüm gereksiz görünüyor.
Kod: 
Sub kaydet()
Dim kayit, lis As Integer
Dim xKontrol As String
Dim c As Range, ilk, ilk2 As String
Dim sor As Long
Dim adt, tc As Double
'................
If Len(Sayfa6.Range("D13").Value) <> 11 Then MsgBox "TC NO 11 RAKAM OLMALI": Exit Sub
'................
Application.Calculation = xlCalculationManual
sat = Sheets(2).[A65536].End(3).Row
xKontrol = "boş"
kayit = 0
adt = WorksheetFunction.CountIf(Sayfa2.Range("A2:A" & sat), Trim(Sayfa6.Range("D1").Text))
tc = WorksheetFunction.CountIf(Sayfa2.Range("M2:M" & sat), Trim(Sayfa6.Range("D13").Text))
If adt > 0 And tc > 0 Then
'.......................
If tc > 1 Then sor = MsgBox("VERİ SAYFASINDA; AYNI TC NO'LU " & tc & " KİŞİ VAR KAYIT YAPILSINMI? " & vbCrLf & "ÜST SIRADAKİ BULUNANA YAPILIR", vbYesNo)
If sor = vbNo Then Exit Sub
'.....................
Dim list() As Variant
ReDim list(adt)
lis = 0
Set c = Sayfa2.Range("a2:a" & sat).Find(Trim(Sayfa6.Range("D1").Text), Lookat:=xlWhole)
If Not c Is Nothing Then
ilk = c.Address
Do
list(lis) = c.Row
lis = lis + 1
Set c = Sayfa2.Range("a2:a" & sat).FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> ilk
End If
Set c = Nothing
Set c = Sayfa2.Range("m2:m" & sat).Find(Trim(Sayfa6.Range("D13").Text), Lookat:=xlWhole)
If Not c Is Nothing Then
ilk2 = c.Address
Do
For q = LBound(list) To UBound(list)
If list(q) = c.Row Then
xKontrol = "bulundu"
kayit = c.Row
Exit For
End If
Next
If xKontrol = "bulundu" Then Exit Do
Set c = Sayfa2.Range("m2:m" & sat).FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> ilk2
    End If
End If
If xKontrol = "boş" Then
kayit = sat + 1
End If
For ix = 1 To 23
Sheets(2).Cells(kayit, ix) = Range("d" & ix)
Next
Erase list
Application.Calculation = xlCalculationAutomatic
Call Sayfa2.Birles
End Sub

Sayfa2 (veri) sayfasındaki kod yerine;

Kod: 
Sub Birles()
Application.Calculation = xlCalculationManual
satır = Cells(Rows.Count, "e").End(3).Row
Range("f2:f" & satır).Formula = "=RC[-1]&""/""&RC[1]"
Application.Calculation = xlCalculationAutomatic
Range("f2:f" & satır).Value = Range("f2:f" & satır).Value

End Sub
 
Son düzenleme:
Yardımınız için teşekkür ederim Sayın Plint.Tüm kodu olduğu gibi yapıştırdım.Gayet hızlı kayıt yaptı önceki duruma göre ama 50 den fazla kayıt yaptıktan sonra dosya kapanır gibi görüntü gidip gelmeye başladı .Acaba çıkarmam gereken bölüm mü vardı bilemedim. Ayrıca Güllübucak a selam
 
önder34' Alıntı:
Yardımınız için teşekkür ederim Sayın Plint.Tüm kodu olduğu gibi yapıştırdım.Gayet hızlı kayıt yaptı önceki duruma göre ama 50 den fazla kayıt yaptıktan sonra dosya kapanır gibi görüntü gidip gelmeye başladı .Acaba çıkarmam gereken bölüm mü vardı bilemedim. Ayrıca Güllübucak a selam
Genişletmek için tıkla ...
Merhaba
Aleyküm selam,
Kodlar iki arama yapıyor 2 kriterle eşleşen aynı satır varsa satır numarasını alıyor. İşlemciyi sizin önceki kodlarınızdaki "for" döngüsünden çok daha az yorar. Etkilediğini sanmam ama listeyi temizlemesi için aşağıdaki mavi bölümü ekleyin. Sorun kırmızı bölümle çalıştırılan kod olabilir.

Kod: 
 [COLOR="Red"]Call Sayfa2.Birles[/COLOR]
[COLOR="Blue"]erase list[/COLOR]
[COLOR="DarkOrange"]Application.Calculation = xlCalculationAutomatic[/COLOR]
End Sub

Sayfada formül çoksa ondan her kayıt girme sonunda olur
"Application.Calculation = xlCalculationManual" otomatik hesaplamayı kapatır
kodların sonunda açılır.

Dosyanızdaki özel bilgileri silerek; bir örnek dosya ekleyip indirme adresini,bildirirseniz.Buraya
 
Son düzenleme:
Merhaba
Yukarıdaki kod küçük eklemeler ile değişti, önceki haliylede denediğimde kayıtta herhangi bir
hata vermedi; ekdeki (aynı kodlu) dosyada kayıt a tıkladığınızda deneme amaçlı arka arkaya 100 kayıt yapacak 12 sn sürdü ve hata vermedi
"Sayfa2" deki " Sub Birles()" makro içinde yeni kod yukarıdaki mesaja eklendi
Değişen kodları kullanın
 
Son düzenleme:
Yardımınız için çok teşekkür ederim .Excel 2010 da denedim şimdi sıkıntısız kayıt yaptı.İşyerinde Excel 2007 de kullanılıyor pazartesi deneyeceğim .Sorunsuz olacağına inanıyorum.
 
Tekrar merhaba işyerinde ancak bugün bakabildim.Kayıt işlemini hızlı bir şekilde yapıyor ama kayıt sayfasındaki taksit işlemlerinde bazen yanlışlık olabiliyor.Örneğin 30 TL yerine 20 TL girilmiş gibi .Değiştirip kaydet dediğimde kullandığımız kodda şu satır sarı renge dönüştü.
list(lis) = c.Row
Daha önce değişiklik yaptığımızda yeni veriye eski veriyi güncelleme yapıyordu.(Tekrar kayıt yapmadan)Sanırım kodda bir eksiklik var
 
Merhaba
"Tc No" değilde "Okul no" yu arayacak şekilde deneyelim.

Kod: 
 Sub kaydet()
Dim kayit
Dim ix As Integer
Dim xKontrol As String
Dim c As Range, ilk As String
Dim sor As Long
If Len(Sayfa6.Range("D13").Value) <> 11 Then MsgBox "TC NO 11 RAKAM OLMALI": Exit Sub
Application.Calculation = xlCalculationManual
sat = Sayfa2.[A65536].End(3).Row: kayit = 0: xKontrol = "boş"
Set c = Sayfa2.Range("A2:A" & sat).Find(Trim(Sayfa6.Range("D1").Text), lookat:=xlWhole)
If Not c Is Nothing Then
ilk = c.Address
Do
If Trim(Sayfa2.Cells(c.Row, 1).Text) = Trim(Sayfa6.Range("D1").Text) And Trim(Sayfa2.Cells(c.Row, 13).Text) = Trim(Sayfa6.Range("D13").Text) Then
kayit = c.Row
xKontrol = "bulundu"
End If
Set c = Sayfa2.Range("A2:A" & sat).FindNext(c)
If c Is Nothing Then Exit Do
Loop While Not c Is Nothing And c.Address <> ilk
End If
If xKontrol = "boş" Then
tc = WorksheetFunction.CountIf(Sayfa2.Range("M2:M" & sat), Trim(Sayfa6.Range("D13").Text))
If tc > 0 Then sor = MsgBox("VERİ SAYFASINDA; OKUL NO DEĞİŞİK AMA AYNI TC NO'LU " & tc & " KİŞİ VAR YENİ KAYIT YAPILSINMI? ", vbYesNo)
If sor = vbNo Then Exit Sub
kayit = sat + 1
End If
For ix = 1 To 23
Sheets(2).Cells(kayit, ix) = Sayfa6.Range("d" & ix)

Next
Application.Calculation = xlCalculationAutomatic
Call Sayfa2.Birles
End Sub

Eklediğiniz dosyadaki "Sayfa2.Birles" makrosundaki
döngü yavaşlatıyor aşağıdaki gibi deneyin.
Kod: 
 Sub Birles()
Application.Calculation = xlCalculationManual
satır = Cells(Rows.Count, "e").End(3).Row
Range("f2:f" & satır).Formula = "=RC[-1]&""/""&RC[1]"
Application.Calculation = xlCalculationAutomatic
Range("f2:f" & satır).Value = Range("f2:f" & satır).Value

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst