powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Подскажите как разбить текс по ширене столбца
12 сообщений из 12, страница 1 из 1
Подскажите как разбить текс по ширене столбца
    #37728189
puma_q
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Есть текст, например: Кран шаровой запорный, номинальный диаметр DN 100; номинальное давление PN 1,6 (МПа); тип присоединения к трубопроводу под приварку; класс герметичности А по ГОСТ 9544-05; под электропривод ЭПП-1800.F14.60.Т024-УХЛ1-а, с заводским антикоррозионным покрытием, сейсмостойкость С, климатическое исполнение ХЛ1 (t мин -60, t макс +40), присоединяемая труба 108х4, рабочая среда нефть. Установка подземно. Комплектность: с удлинителем штока 2,5 м.

Необходимо этот текст разбить по ширене (Columns("B:B").ColumnWidth = 65.71) столбца на несколько подстрок, чтобы каждая подстрака вставлялась в ячейку находящуюся ниже... См. файл...
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37728197
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
puma_q,

F1
Код: vbnet
1.
Justify
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37728844
puma_q
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Спасибо за подсказку, но:
1. Эта функция не работает с текстом более 255 символов :(.
2. Мне к тому же нужно что бы следующая подстрока вставлялась в добавленную строку, т.е. сначала определяем сколько получится подстрок, затем добавляем новые строки по количеству полученных подстрок и уже в эти добавленные строки заносим подстроки....

Каламбур какой то получился... :)
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37730930
puma_q
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
Посмотрите что получилось... Но есть несколько нюансов:
1. Почему то всё равно не получается добиться переноса текста как в Excele (в ячейке A1)
2. Этот код не учитывает размера шрифта в ставляемой ячейки.... допустим размер изменимна 12 в ставляемой ячейки...

Как можно доработать этот код? Как можно определить ширину символа с учётом конкретного размера шрифта?
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731343
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
puma_q,
очень приблизительно......
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
Sub puma_q()
w = Int(Worksheets("Лист1").Columns("A:A").ColumnWidth)
s = Split(Cells(1, 1).Value, " ")
zz = Cells(1, 1).Font.Size
w = Int(w * 10 / zz)
For i = 0 To UBound(s)
If Len(s(i)) + Len(tt) < w Then tt = tt & s(i) & " " Else a = a & tt & vbTab: tt = ""
Next
a = Split(a & tt, vbTab)
[a3].Resize(UBound(a) + 1) = Application.Transpose(a)
End Sub

...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731364
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Извиняюсь чуть строка неправильная...
Код: vbnet
1.
.......Else a = a & tt & vbTab: tt = s(i)
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731375
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
Вот весь код
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
Sub puma_q()
w = Int(Worksheets("Лист1").Columns("A:A").ColumnWidth)
s = Split(Cells(1, 1).Value, " ")
zz = Cells(1, 1).Font.Size
w = Int(w * 10 / zz)
For i = 0 To UBound(s)
If Len(s(i)) + Len(tt) < w Then tt = tt & s(i) & " " Else a = a & tt & vbTab: tt = s(i) & " "
Next
a = Split(a & tt, vbTab)
[a3].Resize(UBound(a) + 1) = Application.Transpose(a)
End Sub

...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731436
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
И еще поправочка маленькая

Код: vbnet
1.
w = Int(w * 11 / zz)



Так более точно.
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731489
puma_q
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
спасибо за помощь, но есть нюансик: не обрабатывается случай если длина одного слова больше ширины ячейки.....
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731518
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
puma_q,
Ну не все же мне делать... пусть и Вам чего останеться
если длинна слова больше ширины ячейки , тогда чего делаем :))
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37731645
puma_q
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Гость
R Dmitry если длинна слова больше ширины ячейки , тогда чего делаем :))

Тогда берём количесвто символов равное ширины ячейки (сколько в ней может уместится), остальные переносим на новую строку.... Такой способ вроде в самой Excel сделан....
...
Рейтинг: 0 / 0
Подскажите как разбить текс по ширене столбца
    #37732076
R Dmitry
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Участник
puma_q,
Option Explicit
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
Sub test()
РазбивкаТекстаНаСтроки Cells(1, 1)
End Sub
Sub РазбивкаТекстаНаСтроки(SplitCell As Range)
Dim w&, ww&, zz&, s, a, i&, j&, tt$
w = Int(SplitCell.ColumnWidth)
s = Split(SplitCell.Cells(1).Value, " ")
zz = SplitCell.Cells(1).Font.Size
w = Int(w * 11 / zz)
    For i = 0 To UBound(s)
     ww = Len(s(i))
        If ww + Len(tt) < w Then
            tt = tt & s(i) & " "
        Else
            a = a & tt & vbTab
                    If ww > w Then
                        For j = 0 To Int(ww / w)
                            If j = Int(ww / w) Then
                                tt = Mid(s(i), (j * w) + 1, w) & " "
                            Else
                                a = a & Mid(s(i), (j * w) + 1, w) & vbTab
                            End If
                        Next
                    Else
            tt = s(i) & " "
            End If
        End If
    Next
a = Split(a & tt, vbTab)
SplitCell.Resize(UBound(a)).Offset(1).Insert Shift:=xlDown
SplitCell.Resize(UBound(a) + 1).Value = Application.Transpose(a)
End Sub

...
Рейтинг: 0 / 0
12 сообщений из 12, страница 1 из 1
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Подскажите как разбить текс по ширене столбца
Найденые пользователи ...
Разблокировать пользователей ...
Читали форум (0):
Пользователи онлайн (0):
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]