Как выделит слова

[Blaster]

Очен нужен помошь ребята.
Вопрос такой:Например у меня есть 10000 слов на Еxcell-e.Слова написаны на столбике A .И среди этих ячейк есть такие которые содержат 2 слова. их примерно 150. Как можно написать код который при нажатии кнопки выделит все те ячейки которые содержат 2 слова и выписать их на другой файл, например под именем Example.xls ?

[Tuco]

Выбрать ячейки, содержащие несколько слов можно, проверяя содержимое на наличие пробела:

if instr((cells(i,j).value), " ")<>0 then
cells(i,j).select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
end if

ну а потом новую книгу назовёшь, как тебе нужно.
Но это только для одной ячейки работает....

[Blaster]

Спасибо за ответ, уже зделал

[Tuco]

2 pashulka:
Я помог, чем мог, кроме меня никто ничего вообще не предложил... Вы же, например, только меня прокритиковали. ваш пост для человека куда более полезен был...

[alibek]

Посчитать количество слов в тексте:

Код: Выделить всё

Function WordCount(ByVal Text As String) As Long
Dim P As Long, C As Long
Text = Replace(Text, vbNewLine, " ")
Text = Replace(Text, vbCr, " ")
Text = Replace(Text, vbLf, " ")
Text = Replace(Text, ".", " ")
Text = Replace(Text, ",", " ")
Text = Replace(Text, ":", " ")
Text = Replace(Text, ";", " ")
Text = Replace(Text, "-", " ")
P = Len(Text)
Do
  Text = Replace(Text, "  ", " ")
  If Len(Text) = P Then Exit Do
Loop
Text = Trim$(Text)
If Len(Text) = 0 Then Exit Function
C = 1
P = 1
Do
  P = InStr(P, Text, " ")
  If P = 0 Then Exit Do
  C = C + 1
  P = P + 1
Loop
WordCount = C
End Function

Пройтись циклом по всем ячейкам, и если WordCount(Cells(Row,Col))>1, то выписать слова в новую книгу.

[Blaster]

To tuco и alibek

Спасибо ребята за внимане ,для новичка в VBA это большой помошь

to pashulka
Без критики нет прогресса. За примерчик ешо раз пасиб.

Возник у меня ешо один вопрос.
Ну например надо вырезать и столбик А и столбик B,тогда как быть? На этом коде меняю Row на 2,но ничего не получается.И если можно скажите как зделать вместо Copy --вырезать( Cut).

[alibek]

Selection.Cut

Но помоему лучше вообще обойтись без буфера обмена.
Приблизительно такой код (подкорректируй под свои нужды):

Код: Выделить всё

Dim R As Long, C As Long, I As Long, S As String
Dim ShSource As Worksheet, ShTarget As Worksheet
Const Rows As Long = 10000&, Cols As Long = 2
Set ShSource = ActiveSheet
Workbooks.Add
Set ShTarget = ActiveSheet
I = 0
For C = 1 To Cols
  For R = 1 To Rows
    S = ShSource.Cells(R, C).Text
    If WordCount(S) > 1 Then
      I = I + 1
      ShTarget.Cells(I, C).Text = S
    End If
  Next R
Next C
Set ShSource = Nothing
Set ShTarget = Nothing