Вычисляй, сколько символов может быть отображено в ячейке с учетом ее размера, и размера шрифта, и хапай левую часть.
Котяра, ты сам то объем этой задачи понимаешь? тут надо API подтягивать, чтоб размер текста вычислять, который зависит не только от размера, но и от самого шрифта. При этом обрезание может быть даже по самой букве и зависит еще и от масштаба.
Тут лучше от задачи первичной отталкиваться. Что конкретно нужно. Для его это все. Может есть варианты иные.
Вычисляй, сколько символов может быть отображено в ячейке с учетом ее размера, и размера шрифта, и хапай левую часть.
Котяра, ты сам то объем этой задачи понимаешь? тут надо API подтягивать, чтоб размер текста вычислять, который зависит не только от размера, но и от самого шрифта. При этом обрезание может быть даже по самой букве и зависит еще и от масштаба.
Тут лучше от задачи первичной отталкиваться. Что конкретно нужно. Для его это все. Может есть варианты иные.bmv98rus
вот не надо столь категорично, если интересует авто перенос на строку, которую просто не видно, то варианты есть, они кривые, но ... Просто как идея
[vba]
Код
Sub ttt() Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = False Set SCELL = Cells(1, 4) SCELL.Copy Set sh = ActiveSheet Set tsh = Sheets.Add(After:=ActiveSheet) With Range("a1") .ColumnWidth = SCELL.ColumnWidth .RowHeight = SCELL.RowHeight .PasteSpecial (xlPasteFormats) A = Split(SCELL, " ") For I = 0 To UBound(A) .Value = LTrim(.Value & " " & A(I)) .EntireRow.AutoFit If .RowHeight <> SCELL.RowHeight Then Exit For
Next End With For I = 0 To I - 1 B = LTrim(B & " " & A(I)) Next
[/vba]
По идее лучше .RowHeight <> SCELL.RowHeight заменить на сравнение со значимой дельтой. Если исходная строка была например не совсем вровень, а чуть более или чуть менее. Лист моно не создавать, а использовать текущий и брать самую последнюю ячейку с Offset(1,1), но есть проблема, с каждым разом она перемещается вс е дальше итак до записи файла пока USEDRANGE не сбросится до используемого.
[vba]
Код
Sub ttt() Application.EnableEvents = False Application.ScreenUpdating = False
Set SCELL = Cells(1, 4) Set tcell = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 1) With tcell SCELL.Copy Destination:=.Cells(1) .ClearContents .ColumnWidth = SCELL.ColumnWidth .RowHeight = SCELL.RowHeight A = Split(SCELL, " ") For i = 0 To UBound(A) .Value = LTrim(.Value & " " & A(i)) .EntireRow.AutoFit If .RowHeight > SCELL.RowHeight Then Exit For Next addr = .Address
End With Range(addr).EntireColumn.Delete Range(addr).EntireRow.Delete For i = 0 To i - 1 b = LTrim(b & " " & A(i)) Next Application.EnableEvents = True Application.ScreenUpdating = True MsgBox b End Sub
вот не надо столь категорично, если интересует авто перенос на строку, которую просто не видно, то варианты есть, они кривые, но ... Просто как идея
[vba]
Код
Sub ttt() Application.DisplayAlerts = False Application.EnableEvents = False Application.ScreenUpdating = False Set SCELL = Cells(1, 4) SCELL.Copy Set sh = ActiveSheet Set tsh = Sheets.Add(After:=ActiveSheet) With Range("a1") .ColumnWidth = SCELL.ColumnWidth .RowHeight = SCELL.RowHeight .PasteSpecial (xlPasteFormats) A = Split(SCELL, " ") For I = 0 To UBound(A) .Value = LTrim(.Value & " " & A(I)) .EntireRow.AutoFit If .RowHeight <> SCELL.RowHeight Then Exit For
Next End With For I = 0 To I - 1 B = LTrim(B & " " & A(I)) Next
[/vba]
По идее лучше .RowHeight <> SCELL.RowHeight заменить на сравнение со значимой дельтой. Если исходная строка была например не совсем вровень, а чуть более или чуть менее. Лист моно не создавать, а использовать текущий и брать самую последнюю ячейку с Offset(1,1), но есть проблема, с каждым разом она перемещается вс е дальше итак до записи файла пока USEDRANGE не сбросится до используемого.
[vba]
Код
Sub ttt() Application.EnableEvents = False Application.ScreenUpdating = False
Set SCELL = Cells(1, 4) Set tcell = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 1) With tcell SCELL.Copy Destination:=.Cells(1) .ClearContents .ColumnWidth = SCELL.ColumnWidth .RowHeight = SCELL.RowHeight A = Split(SCELL, " ") For i = 0 To UBound(A) .Value = LTrim(.Value & " " & A(i)) .EntireRow.AutoFit If .RowHeight > SCELL.RowHeight Then Exit For Next addr = .Address
End With Range(addr).EntireColumn.Delete Range(addr).EntireRow.Delete For i = 0 To i - 1 b = LTrim(b & " " & A(i)) Next Application.EnableEvents = True Application.ScreenUpdating = True MsgBox b End Sub
bmv98rus, спс. временно на это забиваю - надо немного поработать:) для интереса пробовал: сохранить как .prn =почти .pdf - Acrobat Reader DC - сохранить текст (эксель платно) = 100% результат (но это все не то наверное) ладно через пару лет решу (наверное)
bmv98rus, спс. временно на это забиваю - надо немного поработать:) для интереса пробовал: сохранить как .prn =почти .pdf - Acrobat Reader DC - сохранить текст (эксель платно) = 100% результат (но это все не то наверное) ладно через пару лет решу (наверное)Nic70y
ЮMoney 41001841029809
Сообщение отредактировал Nic70y - Вторник, 24.08.2021, 08:21
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
