превращение ячеек Excel в текст Word

[rustamh]

Погомите пожалуйста решить задачу Excel!! Есть несколько параллельных столбцов в таблице. Мне нужно получить из них сплошной текст. Сейчас я переношу просто нужные столбцы в Word и делаю там "объединить ячейки". В результате получается сплошной текст - вместо столбиков - знаки абзацев. Потом я делаю "Найти и заменить" и заменяю все абзацы на пробелы. Можно ли сделать так, чтобы в Excele была одна кнопочка, при нажатии на которую выделенные ячейки превращались бы в сплошной удобный текст (в Worde или в блокноте? Если да напишите пожалуйста как это сделать. Заранее спасибо.

 

[Tanya]

Конечно можно такое сделать, но только знать бы в Worde или в блокноте? то есть в каком же все же виде должно быть )))

В общем перебрасываем в Word.

Sub RangeToWord()
Dim i As Integer, j As Integer
Dim s As String
Dim Wrd As Object

'получаем текст всего листа
With ActiveSheet.UsedRange
For i = .Column To .Column + .Columns.Count
For j = .Row To .Row + .Rows.Count
'пропускаем пустые ячейки
If Len(.Cells(j, i).Value) Then
s = s & .Cells(j, i).Value & " "
End If
Next j
Next i
End With

'активируем ворд
Application.ActivateMicrosoftApp xlMicrosoftWord
Set Wrd = GetObject(, "Word.Application")

If Not Wrd Is Nothing Then
'если нет открытых документов, то создаем новый
If Wrd.Documents.Count = 0 Then
Wrd.Documents.Add.ActiveWindow.Activate
End If

'в позицию курсора вставляем текст
Wrd.ActiveWindow.Selection.TypeText Text:=s + vbCrLf

'закрываем ссылку на ворд
Set Wrd = Nothing
End If
End Sub

Дальше создаем кнопку и вешаем на нее этот макрос

 

[rustamh]

Tanya - это просто чудо. 2 раза в жизни я обращался за помощью к форумам - и оба раза мне помогала Таня!!! Спасибо большое!!!

 

[Tanya]

))) на здоровье!

 

[rustamh]

Таня, а можно проделать все то же самое - только чтобы в Word форматирование сохранилось. Например - если в разных столбцах Excel стоят разные шрифты с разными размерами - то что бы в Word они отображались также.

 

[Tanya]

Можно, есть вариант, только теперь - гораздо меделеннее )))

Sub RangeToWord()

Dim i As Integer, j As Integer
Dim s As String
Dim Wrd As Object 

Application.ActivateMicrosoftApp xlMicrosoftWord
Set Wrd = GetObject(, "Word.Application")
If Not Wrd Is Nothing Then
If Wrd.Documents.Count = 0 Then
Wrd.Documents.Add.ActiveWindow.Activate
End If

With ActiveSheet.UsedRange
For j = .Row To .Row + .Rows.Count		  
For i = .Column To .Column + .Columns.Count
If Len(.Cells(j, i).Value) Then
Wrd.ActiveWindow.Selection.Font.Bold = .Cells(j, i).Font.Bold

'тут подстава))) с их индивидуальными константами в зависимости от приложения!
If .Cells(j, i).Font.Underline = xlUnderlineStyleSingle Then
Wrd.ActiveWindow.Selection.Font.Underline = 1 'wdUnderlineSingle
Else
Wrd.ActiveWindow.Selection.Font.Underline = 0
End If

Wrd.ActiveWindow.Selection.Font.Size = .Cells(j, i).Font.Size
Wrd.ActiveWindow.Selection.Font.Strikethrough = .Cells(j, i).Font.Strikethrough
Wrd.ActiveWindow.Selection.Font.Italic = .Cells(j, i).Font.Italic
Wrd.ActiveWindow.Selection.Font.Color = .Cells(j, i).Font.Color

Wrd.ActiveWindow.Selection.TypeText Text:=.Cells(j, i).Value & " "
End If
Next i
Next j

Wrd.ActiveWindow.Selection.TypeText vbCrLf
End With

'закрываем ссылку на ворд
Set Wrd = Nothing
End If
End Sub

Думаю, что даже за такой медленный вариант достойна +1 :blink:

 

[rustamh]

Таня, ты за предыдущую подсказку точно заработала +10 (только я не знаю как тебе добавить эти баллы). а вот последний вариант у меня не работает :-( . А ты могла бы посмотреть мой конкретный пример Excel и попробовать помочь мне? Очень нужна помощь специалиста. Суть в том, чтобы объединить ячейки файла

Ссылка скрыта от гостей

в сплошной текст. Загвоздка еще в том, что таблица содержит в разных столбцах разные направления письма (справа на лево и с лева направо). В итоговом Worde это тоже должно сохраниться. А последнее решение, которые ты мне дала - вообще не работает никак. Останавливается на одной строке и выдает ошибку. Заранее благодарен.

 

[Tanya]

Совершенно верно, в предыдущем примере я пропустила обработчик ошибок и не учла некоторые тонкости при установке шрифта.
То что ты хочешь, так как я это делала решить сложно. Проще всего сделать именно так как ты и просил сначала:
копируем, вставляем и заменяем )))) и не нужно ничего выдумывать нового )))

Sub RangeToWord2()

Dim Wrd As Object 'получаем текст всего листа

'перехват ошибки
On Error Resume Next

'активируем ворд
Application.ActivateMicrosoftApp xlMicrosoftWord
Set Wrd = GetObject(, "Word.Application")

If Wrd Is Nothing Then
Set Wrd = CreateObject("Word.Application")
End If

If Not Wrd Is Nothing Then
'если нет открытых документов, то создаем новый
If Wrd.Documents.Count = 0 Then
Wrd.Documents.Add.ActiveWindow.Activate
End If

ActiveSheet.UsedRange.Copy

'Wrd.ActiveWindow.Selection.PasteExcelTable False, False, False
With Wrd.ActiveDocument
.Range.PasteExcelTable False, False, False
.Tables(1).ConvertToText Separator:=3, NestedTables:=True

With .Range.Find
.ClearFormatting
.Replacement.ClearFormatting

'заменяем абзацы
.Execute FindText:="^p", Replace:=2, ReplaceWith:=" "

'Дальше, при необходимости можно удалить
'заменяем двойные пробелы на одинарные
.Execute FindText:=" ", Replace:=2, ReplaceWith:=" "
'и на всякий случай еще раз
.Execute FindText:=" ", Replace:=2, ReplaceWith:=" "
End With

'перемещаем выделение на начало документа
.Range(Start:=.Range.Start, End:=.Range.Start).Select
End With

'закрываем ссылку на ворд
Set Wrd = Nothing
End If
End Sub

На твоем примере вроде отработало нормально. Но все может быть )))) могут быть и ошибки ...

 

[rustamh]

Спасибо большое! Как я могу отблагодарить тебя?
Все работает отлично. А проделать все то же самое для блокнота сложно? Когда я просто вставляю в блокнот текст из Word - получается ерунда - скобки и другие значки отображаются неверно.
Мне уже неловко тревожить тебя - но все-таки, можно я буду тебе писать по дальшейшей доработке макроса? Просто если самому разбираться во всем этом - может несколько дней уйти - а тебе наверное для этого минуты нужны.
Еще раз большое спасибо

 

[Tanya]

Насчет минут - ты не прав, мне тоже нужно некоторое количество времени
потомучто я не работаю с VBA, когда-то работала с VBA Excel, в Word пытаюсь по аналогии,
но Word прилично отличается от Excel (хотя, казалось бы )))))

Для блокнота так не сделаешь, потомучто там один шрифт, одна кодировка, а в твоем тексте разные настройки.
К тому же в макросе используются классы приложений Excel и Word, а объектной модели Блокнота, насколько я знаю - нет.

А смысл делать для блокнота?

 

[rustamh]

если делать для блакнота - то не требуется сохранение размера шрифтов. просто хотя бы чтобы скобки адекватно отображились. если например из Word скопировать и вставить в блакнот - получается фигня. Скобки сбиваются например. Просто некоторые види словарей вроде QDictionary работают в блакнотовском формате. и поэтому текст надо и под них подогнать. А то мне уже как то неловко. А вообще ты очень хорошо помогла, спасибо большое. Твои макросы я уже думаю без проблем буду менять и добиваться разных нужных результатов.
Таня, ты прости пожалуйста, что столько много просьб - но если можно посмотри пожалуйста, что можно сделать для конвертации в Блокнот. Итоговый текст должен иметь вид как в файле

Ссылка скрыта от гостей

Суть в том, что в блокноте когда набираешь текс, надо правой кнопкой управляющие символы Уникода какие-то вставлять. А в экселе и ворде это все по другому делается - просто печатаешь разными раскладками да и все.
Может ты знаешь как можно посмотреть код текста в блакноте? может быть можно взять за основу коды символов в блокноте и в ворде и пометь их?