cümlenin tamamında [ ] içindeki kelimeyi ayrıştırma

[chngrcn]

Merhaba,

Sayfa1 sheet'inin A1 Hücresinde ve A2 hücresinde aşağıda belirtmiş olduğum cümle olduğunu varsayarsak;

[BURSA 23.] İcra dairesi'nin [11/02/2019] tarih ve [5637] numaralı, [MUR SANAYİ VE TİCARET LİMİTED ŞİRKETİ] tarafından [AHMET] [YILMAZ] ad
[BAKIRKÖY 24.] İcra dairesi'nin [02/01/2015] tarih ve [5] numaralı, [TAŞ VASITA ANONİM ŞİRKETİ] tarafından [AHMET] [YILMAZ] a

köşeli parantezler içindeki metni ayrıştırarak Sayfa2 sheet'ine sıralamak istiyorum. Bunu vba kodlamasını nasıl yapabiliriz ?

Not: [BURSA 23.] içindeki noktayı almayacak.
sırasıyla sayfa2 de şöyle olmalı
A1 B1 C1 D1 E1 F1
BURSA 23 11/02/2019 5637 MUR SANAYİ VE TİCARET LİMİTED ŞİRKETİ AHMET YILMAZ
BAKIRKÖY 24 02/01/2015 5 TAŞ VASITA ANONİM ŞİRKETİ AHMET YILMAZ


yardımlarınız için teşekkürler.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.
Not : Kodlar Regular Expressions (Düzenli İfadeler) ile daha kısa olabilir. Umarım bir arkadaşımız da bununla ilgili bir çözüm getirir.

Sub Ayır()

    Dim d, _
        i   As Long, _
        j   As Integer, _
        k   As Integer, _
        Sat As Long, _
        n   As Integer, _
        s1  As Worksheet, _
        s2  As Worksheet
    
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    For i = 1 To s1.Cells(Rows.Count, "A").End(3).Row
        d = Split(s1.Cells(i, "A"), "[")
        n = 0
            Sat = Sat + 1
        For j = 0 To UBound(d)
            If Len(d(j)) <> 0 Then
                n = n + 1
'                Debug.Print j & " " & d(j)
                If j = 1 Then d(j) = Replace(d(j), ".", "")
                If j = 2 Then d(j) = Replace(d(j), "/", ".")
                k = InStr(1, d(j), "]", 1)
                s2.Cells(Sat, n) = Left(d(j), k - 1)
            End If
        Next j
    Next i

End Sub

 

[chngrcn]

Sayın Yeşertener,
Ekli resimde ki satırda hata alıyorum. Neden kaynaklanabilir acaba ? Teşekkürler..

 

[Haluk]

Merhaba,

........
Not : Kodlar Regular Expressions (Düzenli İfadeler) ile daha kısa olabilir. Umarım bir arkadaşımız da bununla ilgili bir çözüm getirir.

Necdet Beyin isteği üzerine Regular Expressions tekniği kullanılarak hazırlanan kodlar aşağıdadır...

Not: Gerekiyorsa, Sheet1 ve Sheet2 sayfa isimlerini kendi dosyanıza göre uyarlamanız gerekir.

Sub Test()
'   Haluk - 13/02/2019
'   E-Posta: sa4truss@gmail.com
'
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim NoA As Long
    Dim regExp As Object, objMatches As Object
    Dim i As Long
   
    Set Sh1 = Sheets("Sheet1")
    Set Sh2 = Sheets("Sheet2")
   
    NoA = Sh1.Range("A" & Rows.Count).End(xlUp).Row
    Sh2.Range("A1:AA" & Rows.Count) = Empty
   
    Set regExp = CreateObject("VBScript.RegExp")
   
    regExp.IgnoreCase = True
    regExp.Global = True
    regExp.Pattern = "(\[)(.*?)(\])"
    For i = 1 To NoA
        If regExp.Test(Sh1.Range("A" & i)) Then
            Set objMatches = regExp.Execute(Sh1.Range("A" & i))
            For j = 0 To objMatches.Count - 1
                Sh2.Cells(i, j + 1) = Replace(objMatches.Item(j).Submatches(1), ".", "")
            Next
        End If
    Next
   
    Sh2.Columns.AutoFit
    Set regExp = Nothing
    Set objMatches = Nothing
    Set Sh1 = Nothing
    Set Sh2 = Nothing
End Sub

.

 

[Haluk]

Bilgi:

Kodla elde edilen Submatches verilerinden Replace fonksiyonu ile "." işaretini ayıklamak yerine, pattern'da grup içine dahil ederek de bu işi yapabilirdik.

.

 

[Asri]

Alternatif olsun,

Sub veriparcala()
  sonsatir = Cells(Rows.Count, "A").End(3).Row
  Sheets("Sayfa2").Cells.Clear
  For i = 1 To sonsatir
     veri = Cells(i, "A").Value
     yeniveri = ""
     For Z = 1 To Len(veri)
        harf = Mid(veri, Z, 1)
        If harf = "[" Then
          verial = True
          GoTo son
        End If
        If harf = "]" Then
           verial = False
           yeniveri = yeniveri & "|"
        End If
        If verial Then
           yeniveri = yeniveri & harf
        End If
son:
     Next Z
     liste = Split(yeniveri, "|")
     For y = LBound(liste) To UBound(liste)
       yazveri = "'" & liste(y)
       If y = 0 Then yazveri = Replace(yazveri, ".", "")
       Sheets("Sayfa2").Cells(i, y + 1).Value = yazveri
     Next y
  Next i
End Sub