Makro ile hucreden kelime gruplari almak

[leonadies]

Ustadlarim. K sutunundaki hucrelerde uzunca metinlerim var. Bu metinler icindeki kelimeler belli gruplar icinde ( ) parantezler icine yazilmakta. Ornegin k1 hucresi
......(Siyah araba) (beyaz cam) (yesil silgi) (mavi canta) .......
Bu ornekte nokta olan yerlerde degisken parantez icinde olmayan metinler olabiliyor. Bu metinlerinde belli bi standarti yok. Kisa da olabiliyor uzunda.
Istegim ise bu hucre icinde var olan parantez gruplari makro yardimi ile sayfa2 A1 den baslayarak sutunlara ayirmasi. Metni sutunlara cevir vb is yapmiyor. Cunku hucreler guncelleniyor. Ve veriler guncellendikce islem devam etmeli.
Yapilabilir mi?

 

[Huseyinkis]

Ekteki Kodları Denermisiniz

Sub Denem()
For i = 1 To Cells(Rows.Count, 11).End(3).Row
Adet = 0: Bas = 0: Bit = 0: Süt = 0
For i1 = 1 To Len(Cells(i, 11))

If Mid(Cells(i, 11), i1, 1) = "(" Then
Bas = i1 + 1
Adet = Adet + 1
End If

If Mid(Cells(i, 11), i1, 1) = ")" Then
Bit = i1 - Bas
Adet = Adet + 1
End If

If Adet = 2 Then
Süt = Süt + 1
Sheets("Sayfa2").Cells(i, Süt) = Mid(Cells(i, 11), Bas, Bit)
Adet = 0
Bas = 0
Bit = 0
End If

Next i1, i
End Sub

 

[yanginci34]

Ekteki örneği incelermisiniz.
Ekli dosyayı görüntüle parantezli ifadeyi ayırma-1.xlsx

 

[antonio]

Alternatif:

Sub parantezli_ifadeyi_ayir()
Dim regexp, veri, alan, hcr, sh As Worksheet, ss As Long

Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
Set alan = sh.Range("A1:A" & ss)
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.Pattern = "\(.*\)"

For Each hcr In alan
    veri = regexp.Execute(hcr).Item(0)
    ayir = Split(Mid(veri, 2, Len(veri) - 2), " ")
    For d = 0 To UBound(ayir)
        sh.Cells(hcr.Row, d + 2) = ayir(d)
    Next d
Next hcr
MsgBox "İşlem tamamlandı.", vbInformation, Application.UserName
End Sub

 

[leonadies]

Ekteki Kodları Denermisiniz

Sub Denem()
For i = 1 To Cells(Rows.Count, 11).End(3).Row
Adet = 0: Bas = 0: Bit = 0: Süt = 0
For i1 = 1 To Len(Cells(i, 11))

If Mid(Cells(i, 11), i1, 1) = "(" Then
Bas = i1 + 1
Adet = Adet + 1
End If

If Mid(Cells(i, 11), i1, 1) = ")" Then
Bit = i1 - Bas
Adet = Adet + 1
End If

If Adet = 2 Then
Süt = Süt + 1
Sheets("Sayfa2").Cells(i, Süt) = Mid(Cells(i, 11), Bas, Bit)
Adet = 0
Bas = 0
Bit = 0
End If

Next i1, i
End Sub

Çalışıyor. Ancak k2 de parantez grupları azaldığında sayfa 2 de eski hali ile kalıyor. Yani güncellemiyor

 

[leonadies]

Ekteki örneği incelermisiniz.
Ekli dosyayı görüntüle 187431

Hiç bir makro yok içinde üstadım

 

[leonadies]

Alternatif:

Sub parantezli_ifadeyi_ayir()
Dim regexp, veri, alan, hcr, sh As Worksheet, ss As Long

Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
Set alan = sh.Range("A1:A" & ss)
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.Pattern = "\(.*\)"

For Each hcr In alan
    veri = regexp.Execute(hcr).Item(0)
    ayir = Split(Mid(veri, 2, Len(veri) - 2), " ")
    For d = 0 To UBound(ayir)
        sh.Cells(hcr.Row, d + 2) = ayir(d)
    Next d
Next hcr
MsgBox "İşlem tamamlandı.", vbInformation, Application.UserName
End Sub

Invalıd Procedure hatası veriyor üstadım.

 

[antonio]

Invalıd Procedure hatası veriyor üstadım.

Örnek dosyayı inceleyiniz.

 

[leonadies]

Örnek dosyayı inceleyiniz.

(mavi arabanın siyah camı) yazısında camı kelimesini silince yan sütunlarda aynen kalıyo. Güncelleme olmuyor. Birde A sütunundaki hücrede boşluk bırakıp alta geçince aynı hatayı veriyor hocam. Benim hücrelerim sürekli güncellenen bir yapıya sahip olacak. her durumda kendini güncellemesi gerekiyor kısacası.

 

[Zeki Gürsoy]

(mavi arabanın siyah camı) yazısında camı kelimesini silince yan sütunlarda aynen kalıyo. Güncelleme olmuyor. Birde A sütunundaki hücrede boşluk bırakıp alta geçince aynı hatayı veriyor hocam. Benim hücrelerim sürekli güncellenen bir yapıya sahip olacak. her durumda kendini güncellemesi gerekiyor kısacası.

Bu durumda proseduru "worksheet_change" olayı altında çalıştırmalısınız.

.

 

[leonadies]

Bu durumda proseduru "worksheet_change" olayı altında çalıştırmalısınız.

.

Tamam onu yaparım sorun değil ancak bu hali ile işlemde sorun var .

 

[yanginci34]

Hiç bir makro yok içinde üstadım

zaten makro ile değil formül ile yapmıştım.

 

[leumruk]

Merhaba,
Sayfa uyarlamasını kendiniz yaparsınız.
Alternatif:

Sub ayir()
sonsat = Cells(Rows.Count, 1).End(3).Row
Range("b1:v" & sonsat).ClearContents
For x = 1 To sonsat
If InStr(1, Cells(x, 1), ")") > 0 Then
deg = Split(Cells(x, 1), ")")
For y = 0 To UBound(deg)
If InStr(1, deg(y), "(") > 0 Then
deg2 = Split(deg(y), "(")
say = UBound(deg2)
Cells(x, y + 2) = deg2(say)
Else
Cells(x, y + 2) = deg(y)
End If
Next
End If
Next
End Sub

 

[Zeki Gürsoy]

Bunu deneyin...

Sub parantezli_ifadeyi_ayir()
Dim regexp, veri, alan, hcr As Range, sh As Worksheet, ss As Long

Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
Set alan = sh.Range("A1:A" & ss)
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.Pattern = "\(.*\)"

For Each hcr In alan
    [COLOR=Blue][B]Range(hcr.Offset(, 1), hcr.End(xlToRight)).ClearContents[/B][/COLOR]
    veri = regexp.Execute(hcr).Item(0)
    ayir = Split(Mid(veri, 2, Len(veri) - 2), " ")
    For d = 0 To UBound(ayir)
        sh.Cells(hcr.Row, d + 2) = ayir(d)
    Next d
Next hcr
MsgBox "İşlem tamamlandı.", vbInformation, Application.UserName
End Sub

 

[leonadies]

Merhaba,
Sayfa uyarlamasını kendiniz yaparsınız.
Alternatif:

Sub ayir()
sonsat = Cells(Rows.Count, 1).End(3).Row
Range("b1:v" & sonsat).ClearContents
For x = 1 To sonsat
If InStr(1, Cells(x, 1), ")") > 0 Then
deg = Split(Cells(x, 1), ")")
For y = 0 To UBound(deg)
If InStr(1, deg(y), "(") > 0 Then
deg2 = Split(deg(y), "(")
say = UBound(deg2)
Cells(x, y + 2) = deg2(say)
Else
Cells(x, y + 2) = deg(y)
End If
Next
End If
Next
End Sub

Sorunsuz çalışıyor. Teşekkür ederim

 

[leonadies]

Bunu deneyin...

Sub parantezli_ifadeyi_ayir()
Dim regexp, veri, alan, hcr As Range, sh As Worksheet, ss As Long

Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
Set alan = sh.Range("A1:A" & ss)
Set regexp = CreateObject("VBScript.RegExp")
regexp.Global = True
regexp.Pattern = "\(.*\)"

For Each hcr In alan
    [COLOR=Blue][B]Range(hcr.Offset(, 1), hcr.End(xlToRight)).ClearContents[/B][/COLOR]
    veri = regexp.Execute(hcr).Item(0)
    ayir = Split(Mid(veri, 2, Len(veri) - 2), " ")
    For d = 0 To UBound(ayir)
        sh.Cells(hcr.Row, d + 2) = ayir(d)
    Next d
Next hcr
MsgBox "İşlem tamamlandı.", vbInformation, Application.UserName
End Sub

Sizin kodda oldu üstadım. Teşekkür ederim