Tek hücre içerisindeki rakamları alt alta getirme

[ASLAN7410]

Merhaba hayırlı günler.

Ekte gönderdiğim excel dosyamda çeşitli rakamlar var, ben bu rakamları word sayfasından alıp excele yapıştırdığımda, A sütundaki satırlar içerisine yapıştırıyor.

Yapmak istediğim butona bastığımda P sütununa bu rakamları alt alta getirmesini istiyorum.

Yardımcı olur musunuz?

 

[Asri]

Satırların düzenli olması gerekmiyor. Sadece önemli olan ilgili satırın rakamlar ve boşluk karakterinden oluşması.
Satırın tümü rakam ve boşluk ise aktarılacak satır olarak tespit edilir. Rakamlar arası da boşluk ile tespit eidlir.

Sub aktar()
'Asri Akdeniz - www.asriakdeniz.com - asriakdeniz@gmail.com
Range("P:P").Clear
satir = 0
For k = 1 To 15
    sonsatir = Cells(Rows.Count, k).End(3).Row
    If sonsatir > 1 Then
        For i = 1 To sonsatir
           veri = Cells(i, k).Value
           If sayimi(veri) Then
              liste = Split(veri, " ")
              For j = LBound(liste) To UBound(liste)
                  If liste(j) <> "" Then
                    satir = satir + 1
                    Cells(satir, "P").Value = liste(j)
                  End If
              Next j
           End If
        Next i
    End If
Next k
End Sub

Function sayimi(sadecesayistr)
  liste = "0123456789 "
  For k = 1 To Len(sadecesayistr)
    harf = Mid(sadecesayistr, k, 1)
    If InStr(liste, harf) = 0 Then
       sayimi = False
       Exit Function
    End If
  Next k
  sayimi = True
End Function

 

[ASLAN7410]

Sayın asri, ilginiz çok teşekkür ediyorum, ellerinize sağlık tam istediğim gibi çalışıyor.

Bu işlemi A sütunu ile K sütunu arasına uygulamak istersek nereleri değiştirmemiş gerekir.

 

[Asri]

Sayın asri, ilginiz çok teşekkür ediyorum, ellerinize sağlık tam istediğim gibi çalışıyor.

Bu işlemi A sütunu ile K sütunu arasına uygulamak istersek nereleri değiştirmemiş gerekir.

A ile K arasındaki bu verilerin sonucu yine P ye mi yazılacak.
Örnek dosya gönderebilir misiniz?

 

[ASLAN7410]

Evet P sütununa yazacak.

 

[ASLAN7410]

Örnek dosya ekte.

Yapmak istediğim A ile K sütunundaki rakamları tek bir sütunda alt alta birleştirmek.

 

[Asri]

Evet P sütununa yazacak.

P ye yazılırken öncelik soldan sağa mı yukarıdan aşağıya mı?

* Önce A1 yı P yaz, sonra B1 yi, sonra K1 i P ye yaz mı?
* Önce A kolonunu P yaz, sonra B kolonunu , sonra K kolonunu P ye yaz mı?

 

[ASLAN7410]

Sayın asri,
* Önce A kolonunu P yaz, sonra B kolonunu , sonra K kolonunu P ye yaz mı? Aynen bu şekilde olursa çok güzel olacak.

 

[Asri]

Sayın asri,
* Önce A kolonunu P yaz, sonra B kolonunu , sonra K kolonunu P ye yaz mı? Aynen bu şekilde olursa çok güzel olacak.

Kod güncellendi.

 

[ASLAN7410]

Sayın asri bey, valla süper oldu, Allah razı olsun, ellerinize sağlık, çok teşekkür ediyorum.

Hayırlı çalışmalar.

 

[Asri]

Sayın asri bey, valla süper oldu, Allah razı olsun, ellerinize sağlık, çok teşekkür ediyorum.

Hayırlı çalışmalar.

Sizden de Allah razı olsun.

For k = 1 To 15 ' buradaki 15 arttırılıp azaltılıp aktarılacak kolon sayısı değiştirilebilir. Burada önemli olan bu rakam P nin kolon sayısına eşit yada fazla olmamalı.

15 kolondan fazla aktarım yapılacak ise buradaki P yi örneğin ZZ yapılabilirsiniz.
Cells(satir, "P").Value = liste(j)

 

[ASLAN7410]

Anladım sayın asri bey, uyarı için de ayrıca çok teşekkür ediyorum.

 

[veyselemre]

Sub test()
    Set reg2 = CreateObject("VBScript.Regexp")
    reg2.Pattern = "[\d]+"
    reg2.Global = True
    With CreateObject("VBScript.Regexp")
        .Pattern = "^[\D]"
        .Global = True
        For Each col In Intersect(Sheets("Sayfa1").UsedRange, [a:k]).Columns
            If WorksheetFunction.CountA(col) > 0 Then
                For Each huc In col.SpecialCells(2)
                    If Not .test(huc.Value) Then
                        For Each elem In reg2.Execute(huc.Value)
                            say = say + 1
                            Cells(say, "P").Value = elem.Value
                        Next
                    End If
                Next huc
            End If
        Next col
    End With
    Set reg2 = Nothing
End Sub

 

[ASLAN7410]

Sayın Veysel Bey, size de ayrı teşekkür ediyorum, bu kodda güzel çalışıyor.

Hayırlı çalışmalar diliyorum.