Makro ile kelime kelime ayırırken belirttiğim cümleleri ayırmasın.

[TanerSaydam]

Merhaba;

Aşağıdaki kod ile B sütunundaki verileri kelime kelime ayırıyorum. İçinden atlayacağı kelimeleri kodladım ama ben "YATAK ODASI" yazanları ayırmadan tek hücreye koysun istiyorum.

Sub Ayır()
Dim son As Integer, s As Integer, k As Byte, kelime As Byte
Dim bak As Object, yaz As Object
Set bak = Worksheets("Sayfa2") 'kelime listesinin olduğu sayfa
Set yaz = Worksheets("Sayfa1") 'kelimelerin ayrılıp yazılacağı sayfa

'kelime sayısı yanlış hesaplanmasın diye çift boşlukları tek boşluğa çeviriyoruz.
Cells.Replace What:=" ", Replacement:=" ", LookAt:=xlPart, SearchOrder:=xlByRows

son = bak.Range("B" & Rows.Count).End(xlUp).Row

For s = 2 To son

boşluk = Len(Trim(bak.Cells(s, "B"))) - Len(Replace(bak.Cells(s, "B"), " ", ""))

For k = 0 To boşluk

If Split(bak.Cells(s, "B"), " ")(k) = "Toplam" Then GoTo satıratla
If Split(bak.Cells(s, "B"), " ")(k) = "MAT" Then GoTo satıratla
If Split(bak.Cells(s, "B"), " ")(k) = "(" Then GoTo satıratla

yaz.Cells(s, 1 + k) = Split(bak.Cells(s, "B"), " ")(k)
End If
Next k
satıratla:
Next s
MsgBox "İşlem başarıyla tamamlandı"
End Sub

 

[askm]

Örnek dosyanızı eklerseniz daha anlaşılır olur.