Metni koşula bağlı olarak sütunlara dönüştürmek

[mozdem]

merhabalar, biraz uzun zaman oldu excel ile çalışmayalı. Yapabilirim sandım ama yapamadım. Öncelikle bu çalışma makro ile cevaplanır ise sanırım benim açımdan daha iyi olacağı düşüncesindeyim.
Ekteki excel dosyama PDF dosyasından veri kopyaladım. Excel dosyamdaki B sütunda bulunan veriler D,E.....Y,Z hücrelerine yazdırılmasını istiyorum.

örnek veri;
Anadolu Grubu Holding AGHOL 4,4% 144,00 ? 14.927 244 196.527 35.069 34,0% 11.923 237 21.758 56.827 3.801 4.463 2,3% 29,9% 7,86 2,35 2,04 0,17 0,78

yukarıdaki veriyi Ecel tablosunda D,E.....Y,Z 2. satıra örnek olarak yaptım. Yapabilmiş olsaydım şu düşünce ile yapacaktım.
Verideki kırmızı işaretli kelime Hepsi büyük harf.
1- Veri içinde ard arda gelen büyük harfli kelimeyi E hücresine yazdır.
2- veri içindeki ard arda gelen verinin solundaki kelimeleri D hücresine yazdır.
3- veri içindeki ard arda gelen verinin sağındaki hücreleri her boşlukta bir hücre atlayarak F,G.... yazdır.

Bir hücre içindeki ard arda gelen en az 3 karakter Büyük harf ise kaçıncı karakter? sorusuna cevap bulabilmiş olsaydım sanırım yapabilirdim diye düşünüyorum.
şimdiden teşekkür ederim.

 

[veyselemre]

Sub test()
    Dim mtch As Object, sut As Integer, i As Long, bol, ii As Byte
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "([a-zA-ZğüÜıİşŞçÇöÖ\s\.]+)(\s)([A-Z]+)([\s\d\.,%-\?ad]+)"
        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            If .test(Range("B" & i).Value) Then
                With .Execute(Range("B" & i).Value)(0)
                    Cells(i, 4).Value = .submatches(0)
                    Cells(i, 5).Value = .submatches(2)
                    bol = Split(Trim(.submatches(3)), " ")
                    For ii = 0 To UBound(bol)
                        Cells(i, ii + 6).Value = bol(ii)
                    Next ii
                End With
            End If
        Next i
    End With
End Sub

 

[mozdem]

Sub test()
    Dim mtch As Object, sut As Integer, i As Long, bol, ii As Byte
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "([a-zA-ZğüÜıİşŞçÇöÖ\s\.]+)(\s)([A-Z]+)([\s\d\.,%-\?ad]+)"
        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            If .test(Range("B" & i).Value) Then
                With .Execute(Range("B" & i).Value)(0)
                    Cells(i, 4).Value = .submatches(0)
                    Cells(i, 5).Value = .submatches(2)
                    bol = Split(Trim(.submatches(3)), " ")
                    For ii = 0 To UBound(bol)
                        Cells(i, ii + 6).Value = bol(ii)
                    Next ii
                End With
            End If
        Next i
    End With
End Sub

Öncelikle cevabınız için çok teşekkür ederim. Elimde olmayan nedenler ile geç geri dönüş yaptığımın farkındayım. Bunun için affınıza sığınıyorum. Kodları denemeden bu cevap yazma ihtiyacını hissettim. Bu gece de test edeceğim. Tekrardan teşekkürlerimi iletirim.

 

[mozdem]

Sub test()
    Dim mtch As Object, sut As Integer, i As Long, bol, ii As Byte
    With CreateObject("VBScript.Regexp")
        .Global = True
        .Pattern = "([a-zA-ZğüÜıİşŞçÇöÖ\s\.]+)(\s)([A-Z]+)([\s\d\.,%-\?ad]+)"
        For i = 2 To Cells(Rows.Count, 2).End(3).Row
            If .test(Range("B" & i).Value) Then
                With .Execute(Range("B" & i).Value)(0)
                    Cells(i, 4).Value = .submatches(0)
                    Cells(i, 5).Value = .submatches(2)
                    bol = Split(Trim(.submatches(3)), " ")
                    For ii = 0 To UBound(bol)
                        Cells(i, ii + 6).Value = bol(ii)
                    Next ii
                End With
            End If
        Next i
    End With
End Sub

Hocam, Tam benim istediğim gibi kodlamayı yapmışsınız. Teşekkür ederim.
Ancak benim hesaplayamadığım bir nokta olduğundan bu durumu kendim çözmeye çalışıyorum.
yapamazsam tekrar konuyu anlatırım. Tekrar teşekkürler