Metin ayırma fonksiyonu, Ktf nin yavaş çalışması!!!!

walabi · 31 Temmuz 2024

Merhaba,

Aşağıda forum üzerinden bulup kullanmaya çalıştığım bir KT fonksiyon var. Ama VBA kullanırken yerel fonksiyonlara göre çok yavaş çalışıyor gibi. Bunun sebebi ne olabilir??

Kod:

Function Metin_Ayır(Txt, n, Ayırıcı) As String
    Dim Txt1 As String, temperament As String
    Dim Elemansayısı As Integer, i As Integer
    Dim Karekter As String
        Txt1 = Txt
    If Ayırıcı = Chr(32) Then Txt1 = Application.Trim(Txt1)
        If Right(Txt1, Len(Txt1)) <> Ayırıcı Then _
        Txt1 = Txt1 & Ayırıcı
        Elemansayısı = 0
    Karekter = ""
        For i = 1 To Len(Txt1)
        If Mid(Txt1, i, 1) = Ayırıcı Then
            Elemansayısı = Elemansayısı + 1
            If Elemansayısı = n Then

                Metin_Ayır = Karekter
                Exit Function
            Else
                Karekter = ""
            End If
        Else
            Karekter = Karekter & Mid(Txt1, i, 1)
        End If
    Next i
    Metin_Ayır = ""
End Function

Korhan Ayhan · 31 Temmuz 2024

Merhaba,

Kullanıcı tanımlı fonksiyonlarda döngü kullandığınızda performans kaybı olabilir.

Siz örnek veriyi paylaşın. Ona göre daha performanslı fonksiyon belki tanımlanabilir.

Muzaffer Ali · 31 Temmuz 2024

Merhaba.
Şunu deneyin.

Kod:

Function Metin_Ayır(Txt, n, Ayırıcı) As String
    Metin_Ayır = Split(Txt, Ayırıcı)(n - 1)
End Function

walabi · 31 Temmuz 2024

Merhaba

Örnek bir dosya eklemeye çalıştım. Amacım şu. Muhasebede muavin olarak bilinen ve genelde Satır Açıklaması gibi bir sütunda nokta ya da virgül gibi karakterle ayrılan, Tarih, Ünvan, Fatura No gibi bilgilerin olduğu tek bir excel sütunundaki verileri ayrım yapan karaktere göre ayırmam gerekiyor. Ancak bu noktata şöylesi bir sıkıntı var. Bazı eğerli yapılar kullanmam gerekiyor. Çünkü Tarih ünvan ve diğer bilgiler ERP programındaki modülün tipine göre yer yer değişiyor.

Örneğin bazen Ünvan 1. virgülden sonra gelirken bazen ise ikinci virgülden sonrra geliyor. Benim kullandığım bu fonksiyonda da Modül tiplerini baz alarak eğerli döngü oluşturmam gerekti.

Ancak yerleşik fonksiyonların örneğin 5 bin satırlık bir veride işlem bitiş süresi birkaç saniye iken bu fonksiyon dakikalar alıyor. Bu problemi çözmeye çalışıyorum açıkcası.

Korhan Ayhan' Alıntı:
Merhaba,

Kullanıcı tanımlı fonksiyonlarda döngü kullandığınızda performans kaybı olabilir.

Siz örnek veriyi paylaşın. Ona göre daha performanslı fonksiyon belki tanımlanabilir.

Kod:

Sub Deneme()

aktifsayfa = ActiveSheet.Name
Set s1 = Sheets(aktifsayfa)

sonsat1 = s1.Cells(Rows.Count, "A").End(3).Row

s1.Range("F2:Z" & sonsat1).ClearContents

For x = 2 To sonsat1
  If WorksheetFunction.CountIfs(s1.Cells(x, "D"), "*" & "SATINALMA FATURASI" & "*") > 0 Then
      s1.Cells(x, "F") = "SATINALMA FATURASI"
  ElseIf WorksheetFunction.CountIfs(s1.Cells(x, "D"), "*" & "SATIŞ FATURASI" & "*") > 0 Then
      s1.Cells(x, "F") = "SATIŞ FATURASI"
  ElseIf WorksheetFunction.CountIfs(s1.Cells(x, "D"), "*" & "İADE FATURASI" & "*") > 0 Then
      s1.Cells(x, "F") = "İADE FATURASI"
  ElseIf WorksheetFunction.CountIfs(s1.Cells(x, "D"), "*" & "VERİLEN HİZMET FATURASI" & "*") > 0 Then
      s1.Cells(x, "F") = "İADE FATURASI"
  Else
      s1.Cells(x, "F") = ""
 
  End If
 
Next x


For i = 2 To sonsat1

  If s1.Cells(i, "F") = "" Then
      s1.Cells(i, "G") = ""

  ElseIf s1.Cells(i, "F") = "SATINALMA FATURASI" Then
      s1.Cells(i, "G") = Metin_Ayır(s1.Cells(i, "D"), 3, ",")
  ElseIf s1.Cells(i, "F") = "İADE FATURASI" Then
      s1.Cells(i, "G") = Metin_Ayır(s1.Cells(i, "D"), 3, ",")
  ElseIf s1.Cells(i, "F") = "VERİLEN HİZMET FATURASI" Then
      s1.Cells(i, "G") = Metin_Ayır(s1.Cells(i, "D"), 3, ",")
  ElseIf s1.Cells(i, "F") = "SATIŞ FATURASI" Then
      s1.Cells(i, "G") = Metin_Ayır(s1.Cells(i, "D"), 4, ",")
  Else
      s1.Cells(i, "G") = ""

  End If

Next i

End Sub

Korhan Ayhan · 31 Temmuz 2024

#3 nolu mesajda önerilen fonksiyonu denediniz mi?

Zeki Gürsoy · 31 Temmuz 2024

Yerleşik fonksiyonlar "C" fonksiyonudur. VB ise üst seviye dil olduğundan doğası gereği yavaştır. Bu, Ferrari ile Şahin'i kıyaslamak gibi olur.

.

walabi · 31 Temmuz 2024

Korhan Ayhan' Alıntı:
#3 nolu mesajda önerilen fonksiyonu denediniz mi?

Muzaffer Ali beye öncelikle teşekkürler.
Örnek dosyadaki verileri 5 bin satır kadar çoğaltarak denemeye çalıştım. İşlem süreleri hemen hemen aynı gibi. Deneme yöntemim yanlış değilse. Eğerli yapılar süreyi artıyor sanki.

halit3 · 31 Temmuz 2024

Kodların başına ve sonuna bunları ekle dene

kodun başına ekle

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With

kodun sonuna ekle

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

walabi · 31 Temmuz 2024

halit3' Alıntı:
Kodların başına ve sonuna bunları ekle dene

kodun başına ekle

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With

kodun sonuna ekle

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

Halit Bey teşekkürler. 35 saniye civarı süren işlem 1 saniye civarında bitmekte. Bu kodlar ne işe yaramakta. Daha önce uygulamalarda gördüm ancak ne işe yaradığını anlamamıştım.

halit3 · 1 Ağustos 2024

Alternatif kodlar

Kod:

Sub ayir()

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With

Dim Zaman As Double
Zaman = Timer
sut = 4

son = Cells(Rows.Count, sut).End(3).Row
Range("F2:Z" & son).ClearContents

For r = 2 To son

hucre = Mid(WorksheetFunction.Trim(Cells(r, sut).Value), 12, 100)

aranan1 = "SATINALMA FATURASI"
aranan2 = "İADE FATURASI"
aranan3 = "VERİLEN HİZMET FATURAS"
aranan4 = "SATIŞ FATURASI"


deg1 = Split(hucre, aranan1)
deg3 = Split(hucre, aranan2)
deg5 = Split(hucre, aranan3)
deg7 = Split(hucre, aranan4)


If UBound(deg1) > 0 Then
deg2 = Split(deg1(1), ",")
Cells(r, 6).Value = aranan1
Cells(r, 7).Value = deg2(1)
GoTo atla
End If


If UBound(deg3) > 0 Then
deg4 = Split(deg3(1), ",")
Cells(r, 6).Value = aranan2
Cells(r, 7).Value = deg4(1)
GoTo atla
End If


If UBound(deg5) > 0 Then
deg6 = Split(deg5(1), ",")
Cells(r, 6).Value = aranan3
Cells(r, 7).Value = deg6(1)
GoTo atla
End If


If UBound(deg7) > 0 Then
deg8 = Split(deg7(1), ",")
Cells(r, 6).Value = aranan4
If Mid(deg7(1), 2, 1) = "x" Then
Cells(r, 7).Value = deg8(2)
ElseIf Mid(deg7(1), 2, 1) = "y" Then
Cells(r, 7).Value = deg8(2)
Else
Cells(r, 7).Value = deg7(1)
End If
End If



If WorksheetFunction.Trim(Cells(r, sut).Value) = "SATIŞ FATURASI" Then
Cells(r, 6).Value = "SATIŞ FATURASI"
End If
atla:
Next


With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

 MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"

End Sub

diğer kod

Kod:

Sub ayir2()

With Application
.Calculation = xlManual '-4135
.ScreenUpdating = False
.EnableEvents = False
End With

Dim Zaman As Double
Zaman = Timer
sut1 = 4
sut2 = 2

son = Cells(Rows.Count, sut1).End(3).Row
Range("F2:Z" & son).ClearContents



ReDim myarr(1 To sut2, 1 To 1)

For r = 2 To son

hucre = Mid(WorksheetFunction.Trim(Cells(r, sut1).Value), 12, 100)

aranan1 = "SATINALMA FATURASI"
aranan2 = "İADE FATURASI"
aranan3 = "VERİLEN HİZMET FATURAS"
aranan4 = "SATIŞ FATURASI"


deg1 = Split(hucre, aranan1)
deg3 = Split(hucre, aranan2)
deg5 = Split(hucre, aranan3)
deg7 = Split(hucre, aranan4)


b = b + 1
ReDim Preserve myarr(1 To sut2, 1 To b)

If UBound(deg1) > 0 Then
deg2 = Split(deg1(1), ",")
myarr(1, b) = aranan1
myarr(2, b) = deg2(1)
GoTo atla
End If

If UBound(deg3) > 0 Then
deg4 = Split(deg3(1), ",")
myarr(1, b) = aranan2
myarr(2, b) = deg4(1)
GoTo atla
End If


If UBound(deg5) > 0 Then
deg6 = Split(deg5(1), ",")
myarr(1, b) = aranan3
myarr(2, b) = deg6(1)
GoTo atla
End If

If UBound(deg7) > 0 Then
deg8 = Split(deg7(1), ",")
myarr(1, b) = aranan4
If Mid(deg7(1), 2, 1) = "x" Then
myarr(2, b) = deg8(2)
ElseIf Mid(deg7(1), 2, 1) = "y" Then
myarr(2, b) = deg8(2)
Else
myarr(2, b) = deg7(1)
End If
End If

If WorksheetFunction.Trim(Cells(r, sut1).Value) = "SATIŞ FATURASI" Then
myarr(1, b) = "SATIŞ FATURASI"
End If

atla:
Next

Range("f2", Cells(son, 7)).Value = WorksheetFunction.Transpose(myarr)

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With

 MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"


End Sub

Metin ayırma fonksiyonu, Ktf nin yavaş çalışması!!!!

walabi

Korhan Ayhan

Administrator

Muzaffer Ali

Destek Ekibi

walabi

Ekli dosyalar

Korhan Ayhan

Administrator

Zeki Gürsoy

Uzman

walabi

Ekli dosyalar

halit3

Uzman

walabi

halit3

Uzman