• DİKKAT

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

Şarta bağlı kelime içinde rakam ayırma

Muzaffer Ali' Alıntı:
Ekteki dosyaların ikisi de aynı. Hem forumda hem harici paylaşım sitesi filemail.com da paylaştım. Siz filemail.com da paylaştığımı indirebilirsiniz.
Genişletmek için tıkla ...
Tekrar slm evet dosyayı indirdim. Ancak benim ilk attığım dosya sandım ancak kod görüntüle deyince kodları gördüm. sayfadaki buton gitmiş bir de kodu çalıştırdığım da type mismatch hatası veriyor
 
Ben denedim ama bir hata alamadım. Siz örnek dosya üzerinde denerken mi hata aldınız yoksa orijinal dosyada mı?
Bir de bu dosyayı inceleyiniz.

www.filemail.com

Secure File Sharing - Filemail

Share files of any size, any format, any type, securely
www.filemail.com www.filemail.com
 
Muzaffer Ali' Alıntı:
Ekteki dosyaların ikisi de aynı. Hem forumda hem harici paylaşım sitesi filemail.com da paylaştım. Siz filemail.com da paylaştığımı indirebilirsiniz.
Genişletmek için tıkla ...
Arkadaşım Emeğine sağlık çok teşekkür ederim. Yardımların için istediğim olmuş dosyayı görünce eksiklerimi de görmeye başlıyorum. Bu yüzden
senden ricam şu;
Şimdi Tırnak işareti olduğunda, tırnaktan önceki rakamı miktar ile çarpıyor burası tamam ancak, tırnak olmaz ise de 1 ile miktarı çarpmasını istiyorum. Birde önceki gönderdiğin de butona basınca tamamını döküyordu. Buton da ekleyebilirsen sevinirim. Teşekkür. İyi çalışmalar,
 
Deneyiniz.

Sayfanıza bir buton ekleyip kodları bir modüle kopyaladıktan sonra butona tanımlayıp kullanabilirsiniz.

C++: 
Option Explicit

Sub Edit_Data()
    Dim Data As Variant, Last_Row As Long
    Dim X As Long, Y As Integer, No As Long
    Dim Matches As Object, Quantity As Double
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
       
    Range("H2:J" & Rows.Count).ClearContents
   
    Last_Row = Cells(Rows.Count, 1).End(3).Row
   
    Data = Range("A2:F" & Last_Row).Value
   
    ReDim Result(1 To Last_Row, 1 To 3)
   
    For X = LBound(Data, 1) To UBound(Data, 1)
        No = No + 1
       
        With VBA.CreateObject("VBScript.RegExp")
            .Pattern = "(\d+)(?='\s*[lL][iıuü])"
            .Global = False
            .IgnoreCase = True
       
            If .Test(Data(X, 2)) Then
                Set Matches = .Execute(Data(X, 2))
                Quantity = CLng(Matches(0).SubMatches(0))
            Else
                Quantity = 1
            End If
        End With
               
        Result(No, 1) = "'" & Data(X, 1)
        Result(No, 2) = Quantity * Replace(Data(X, 4), Chr(160) & "Birim", "")
        Result(No, 3) = CDbl(Replace(Data(X, 6), "$" & Chr(160), ""))
    Next
   
    Range("H2").Resize(No, UBound(Result, 2)) = Result
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
       
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

Sayfanıza bir buton ekleyip kodları bir modüle kopyaladıktan sonra butona tanımlayıp kullanabilirsiniz.

C++: 
Option Explicit

Sub Edit_Data()
    Dim Data As Variant, Last_Row As Long
    Dim X As Long, Y As Integer, No As Long
    Dim Matches As Object, Quantity As Double
   
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
       
    Range("H2:J" & Rows.Count).ClearContents
   
    Last_Row = Cells(Rows.Count, 1).End(3).Row
   
    Data = Range("A2:F" & Last_Row).Value
   
    ReDim Result(1 To Last_Row, 1 To 3)
   
    For X = LBound(Data, 1) To UBound(Data, 1)
        No = No + 1
       
        With VBA.CreateObject("VBScript.RegExp")
            .Pattern = "(\d+)(?='\s*[lL][iıuü])"
            .Global = False
            .IgnoreCase = True
       
            If .Test(Data(X, 2)) Then
                Set Matches = .Execute(Data(X, 2))
                Quantity = CLng(Matches(0).SubMatches(0))
            Else
                Quantity = 1
            End If
        End With
               
        Result(No, 1) = "'" & Data(X, 1)
        Result(No, 2) = Quantity * Replace(Data(X, 4), Chr(160) & "Birim", "")
        Result(No, 3) = CDbl(Replace(Data(X, 6), "$" & Chr(160), ""))
    Next
   
    Range("H2").Resize(No, UBound(Result, 1)) = Result
   
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
    End With
       
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...
Merhaba arkadaşım eline sağlık güzel olmuş. Ancak örnek dosya yı attım. Dosyada da görünüyor. ilk iki satırdan sonra satır sayısı arttıkça yan sütunlara #YOK ibaresi atıyor. Teşekkürler. İyi çalışmalar,
www.filemail.com

Secure File Sharing - Filemail

Share files of any size, any format, any type, securely
www.filemail.com www.filemail.com
 
odcy2000' Alıntı:
Arkadaşım Emeğine sağlık çok teşekkür ederim. Yardımların için istediğim olmuş dosyayı görünce eksiklerimi de görmeye başlıyorum. Bu yüzden
senden ricam şu;
Şimdi Tırnak işareti olduğunda, tırnaktan önceki rakamı miktar ile çarpıyor burası tamam ancak, tırnak olmaz ise de 1 ile miktarı çarpmasını istiyorum. Birde önceki gönderdiğin de butona basınca tamamını döküyordu. Buton da ekleyebilirsen sevinirim. Teşekkür. İyi çalışmalar,
Genişletmek için tıkla ...
Her eklediğim dosyaya buton ekledim ama sizde neden görünmediğini anlamadım.
Şimdi Form Denetimi butonu ekledim ve diğer düzenlemeleri yaptım inceleyiniz.
www.filemail.com

Secure File Sharing - Filemail

Share files of any size, any format, any type, securely
www.filemail.com www.filemail.com
 
#25 nolu mesajımda ki kodu revize ettim. Tekrar deneyiniz...
 
Emeği geçen tüm arkadaşlara tekrardan çok teşekkür ederim. İyi çalışmalar,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst