Hey there!

It looks like you're enjoying Hesaptablosu - Akademik Excel Forumu but haven't created an account yet. Why not take a minute to register for your own free account now? As a member you get free access to all of our forums and posts plus the ability to post your own messages, communicate directly with other members and much more. Register now!

Already a member? Login at the top of this page to stop seeing this message.

Toplam 7 sonuçtan 1 ile 7 arasındakiler gösteriliyor.

Konu: Bu makroyu hızlandırmak

  1. #1
    Yeni Üye
    Üyelik tarihi
    Nov 2017
    Mesajlar
    7

    Bu makroyu hızlandırmak

    Arkadaslar asagıdakı makroyu burdan bır arkadaşımız hazırladı.
    sagolsun fakat 2000 adet satır verı de agır çalışıyor nasıl hızlandırırız yardımcı olurmusunz


    Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
    BUL
    Range(Target.Address).Select
    End Sub

    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("A2:T2")) Is Nothing Then Exit Sub
    'If Target.Column <> 2 Then Exit Sub
    'If Target.Row > 1 Or Target.Row < 9 Then Exit Sub
    BUL
    End Sub


    Private Sub BUL()

    Application.ScreenUpdating = False
    yer = ActiveSheet.Name
    Set sh = Sheets(yer)
    Rows("2:1000").EntireRow.Hidden = False

    For i = 2 To [a65536].End(3).Row + 1
    aranan1 = ""
    aranan2 = ""
    For n = 1 To WorksheetFunction.CountA(Columns("A")) + 1

    If n = 20 Then
    aranan1 = aranan1 & Mid(Format(Cells(i, 20).Value), 1, Len(Cells(2, 20).Value))
    Else
    aranan1 = aranan1 & UCase(Mid(sh.Cells(i, n).Value, 1, Len(Cells(2, n).Value)))
    End If

    aranan2 = aranan2 & UCase(Cells(2, n).Value)

    Next n
    aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))
    aranan2 = UCase(Replace(Replace(aranan2, "I", "İ"), "i", "I"))

    If aranan1 <> aranan2 Then
    Rows(i).EntireRow.Hidden = True
    End If
    Next i

    Application.ScreenUpdating = True



    End Sub

    yardım ıcın teşekkür ederım

  2. #2
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.000
    Mrb,
    Aşağıdaki şekilde deneyebilir misiniz?
    Sağlıcakla kalın.



    Private Sub BUL()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    yer = ActiveSheet.Name
    Set sh = Sheets(yer)
    Rows("2:1000").EntireRow.Hidden = False

    For i = 2 To [a65536].End(3).Row + 1
    aranan1 = ""
    aranan2 = ""
    For n = 1 To WorksheetFunction.CountA(Columns("A")) + 1

    If n = 20 Then
    aranan1 = aranan1 & Mid(Format(Cells(i, 20).Value), 1, Len(Cells(2, 20).Value))
    Else
    aranan1 = aranan1 & UCase(Mid(sh.Cells(i, n).Value, 1, Len(Cells(2, n).Value)))
    End If

    aranan2 = aranan2 & UCase(Cells(2, n).Value)

    Next n
    aranan1 = UCase(Replace(Replace(aranan1, "I", "İ"), "i", "I"))
    aranan2 = UCase(Replace(Replace(aranan2, "I", "İ"), "i", "I"))

    If aranan1 <> aranan2 Then
    Rows(i).EntireRow.Hidden = True
    End If
    Next i

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True


    End Sub

  3. #3
    Yeni Üye
    Üyelik tarihi
    Nov 2017
    Mesajlar
    7
    Yok hocam düzelmedi

  4. #4
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.000
    Mrb,
    Eskiye göre hiç fark etmedi mi?
    Ben kendi programlarımda kullanıyorum işe yarıyor.
    Dosya boyutu ve bilgisayarınızın özelliği de etkiler.
    Office sürümlerinde de farklılık gösteriyor.
    Üstatlardan farklı bir çözüm de gelebilir.
    Birde

    Application.ScreenUpdating = False
    Application.ScreenUpdating = True

    satırlarını silerek/iptal ederek deneyebilir misiniz?

    Sağlıcakla kalın.
    Konu behcet tarafından (18.11.2017 Saat 11:45 ) değiştirilmiştir.

  5. #5
    Yeni Üye
    Üyelik tarihi
    Nov 2017
    Mesajlar
    7
    Alıntı behcet Nickli Üyeden Alıntı Mesajı göster
    Mrb,
    Eskiye göre hiç fark etmedi mi?
    Ben kendi programlarımda kullanıyorum işe yarıyor.
    Dosya boyutu ve bilgisayarınızın özelliği de etkiler.
    Office sürümlerinde de farklılık gösteriyor.
    Üstatlardan farklı bir çözüm de gelebilir.
    Birde

    Application.ScreenUpdating = False
    Application.ScreenUpdating = True

    satırlarını silerek/iptal ederek deneyebilir misiniz?

    Sağlıcakla kalın.
    Hocam hepsını denedım . oficce 2010 makıne i5 12 gb ram yanı aklım almıyor ama yınede ılgınıze teşekkür ederım. Bu sıra da sıze bır sey sormak ıstıyorum bu ışlemı makrosuz yaptırma sansına sahıpmıyız.

  6. #6
    Kıdemli Üye
    Üyelik tarihi
    Jun 2010
    Nereden
    Erbaa
    Versiyon
    2010 TR
    Mesajlar
    1.000
    Tekrar Merhaba,
    Makineniz ve sürüm gayet iyi.
    Belki kodlarda düzenleme ile bu aşılabilir. Ancak üstadların el atması gerekli bence.

    Sağlıcakla kalın.

  7. #7
    Yeni Üye
    Üyelik tarihi
    Nov 2017
    Mesajlar
    7
    Alıntı behcet Nickli Üyeden Alıntı Mesajı göster
    Tekrar Merhaba,
    Makineniz ve sürüm gayet iyi.
    Belki kodlarda düzenleme ile bu aşılabilir. Ancak üstadların el atması gerekli bence.

    Sağlıcakla kalın.
    Evet haklısınız ..

Konu Bilgisi

Users Browsing this Thread

Şu anda 1 üyemiz bu konuya göz atıyor. (0 kayıtlı üye ve 1 misafir.)

Yetkileriniz

  • Konu Acma Yetkiniz Yok
  • Cevap Yazma Yetkiniz Yok
  • Eklenti Yükleme Yetkiniz Yok
  • Mesajınızı Değiştirme Yetkiniz Yok
  •