Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel (архив)
Страницы: 1
RSS
Перенос текста
 
#1
26.07.2012 23:43:00
Добрый вечер, любители VBA!  
Хотелось бы реализовать перенос текстовой строки в Excel.    
Если ширина текстовой строки превышает lw1>425, остальные символы нужно перенести на ячейку в строке ниже.  
Например текст  
вавауклдщщыйзкш (>425), то будет вот так  
вавауклдщщы  
йзкш    
До переноса я пока не дошел, поскольку снова зациклился на цикле, который неправильно работает    
Sub width_rng()  
Dim i As Integer  
Cells(1, 3).EntireColumn.AutoFit  
lw1 = Cells(1, 3).Width  
slw1 = Len(Cells(1, 3).Value)  
slw2 = Len(Cells(1, 3).Value) - (Len(Cells(1, 3).Value) - 1)  
Cells(1, 4).Value = Right(Cells(1, 3).Value, 1)  
Cells(1, 4).EntireColumn.AutoFit  
lw2 = Cells(1, 4).Width  
i = 1  
Do While lw1 > 425  
ilw1 = Right(Cells(1, 3).Value, i)  
Cells(1, 3).EntireColumn.AutoFit  
lw1 = Cells(1, 3).Width  
i = i + 1  
Loop  
Cells(1, 3).ColumnWidth = 1.33  
Cells(1, 4).ColumnWidth = 1.33  
End Sub  
А именно в окне Locals lw1 остается постоянной и невозможно выйти из цикла.
 
 
 
#2
26.07.2012 23:48:48
))
 
 
 
#3
27.07.2012 02:13:07
Sub width_rng_1()  
Cells(1, 3).EntireColumn.AutoFit  
i = 1  
Do While Cells(1, 3).Width > 425  
Cells(2, 3) = Cells(2, 3) & Right(Cells(1, 3), i)  
Cells(1, 3) = Left(Cells(1, 3), Len(Cells(1, 3)) - i)  
Cells(1, 3).EntireColumn.AutoFit  
i = i + 1  
Loop  
End Sub
 
 
 
#4
27.07.2012 08:45:15
Спасибо Вам большое, k61! Действительно работает, как и хотелось.
 
 
 
#5
28.07.2012 20:05:09
Как сделать, чтобы макрос работал при (2,3,5 и т.д.)*425    
Поскольку он работает, когда    
Cells(1, 3).Width немножко больше 425 и Cells(2, 3).Width<425  
И не работает, когда  
Cells(1, 3).Width>425 и Cells(2, 3).Width>425
 
 
 
#6
28.07.2012 20:14:02
другими словами, когда есть длинная строка намного больше 425, ее нужно разнести  
по строкам вниз c учетом переноса, т.е.  
вывывыавпавапрпорророhhghghgh,kklklklklklklklklk >425  
вывывыавпа  
вапрпоррор  
оhhghghgh,  
kklklklklk  
lklklklk
 
 
 
#7
28.07.2012 20:21:13
что-то пробовал, но такой цикл не работает  
Sub width_rng_2()  
Cells(1, 3).EntireColumn.AutoFit  
final = Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp)).Count  
For j = 1 To final Step 1  
i = 1  
Do While Cells(j, 3).Width > 425  
Cells(j + 1, 3) = Cells(j + 1, 3) & Right(Cells(j, 3), i)  
Cells(j, 3) = Left(Cells(j, 3), Len(Cells(j, 3)) - i)  
Cells(1, 3).EntireColumn.AutoFit  
i = i + 1  
Loop  
Next j  
End Sub
 
 
 
#8
28.07.2012 20:25:02
Без VBA:   
http://www.excelworld.ru/forum/2-890-1
 
 
 
#9
28.07.2012 21:12:58
Смотрел ссылку, но думаю подправить мой вариант будет проще.    
Nerv пишет:  
Как вариант макрос, который рассчитывает кол-во символов, которое может поместиться в ячейке (объединенной) исходя из размера, типа шрифта и т.п.  
Вначале тоже думал привязаться к символам текста (у меня шрифт Times New Roman 14).  
Считал количество одинаковых символов, которое может поместиться в ячейке шириной 425 points.  
i 132  y 57  q 59  n 60  
j 136  u 59  h 60  m 38          
l 136  o 54  k 57  
w 41   p 52  z 68    
q 54   a 68  x 58  
e 67   s 68  c 60  
r 90   d 54  v 58  
t 108  f 87  b 53  
Для русских букв не делал.  
А если будет слово с разным набором символов- сложности сразу появляются.
 
 
 
#10
28.07.2012 22:07:37
{quote}{login=tarasso}{date=28.07.2012 09:12}{thema=}{post}Как вариант макрос, который рассчитывает кол-во символов{/post}{/quote}Хотелось бы лицезреть макрос, можете Вы выложить или Саша (если появится)?
Киса, я хочу Вас спросить, как художник — художника: Вы рисовать умеете?
 
 
 
#11
28.07.2012 22:22:46
кажется вот
 
 
 
#12
28.07.2012 23:17:59
Можно так сделать: ячейки, образующие "поле ввода", объединить. Выравнивание - по левому краю, по вертикали, переносить по словам. А "границы ячеек" нарисовать графическими линиями.  
 
В Ворде можно создать связь между несколькими Надписями: если текст не умещается в первой Надписи, он продолжается в другой, третьей и т.д. В Excel надписи таким свойством не обладают.
 
 
 
#13
29.07.2012 00:44:38
пришел еще к такому варианту, который как-никак, но уже работает, правда все-равно равномерно строки не распределяет.  
Sub width_rng_f()  
Dim j As Long, i As Long  
final = Range(Cells(1, 3), Cells(Rows.Count, 3).End(xlUp)).Count  
i = 1  
j = 0  
er:  
If j > final Then Exit Sub  
j = j + 1  
Cells(j, 3).Columns.AutoFit  
Do While Cells(j, 3).Width > 425  
Cells(j + 1, 3) = Cells(j + 1, 3) & Right(Cells(j, 3), i)  
Cells(j, 3) = Left(Cells(j, 3), Len(Cells(j, 3)) - i)  
a = Len(Cells(j, 3))  
Cells(j, 3).Columns.AutoFit  
i = i + 1  
Loop  
Cells(j, 3).ColumnWidth = 1.33 'это нужно, поскольку у меня ячейки - клетки.  
i = 1  
GoTo er  
End Sub
 
 
 
#14
09.08.2012 20:15:29
Здравстуйте, уважаемые гуру! Прощу еще раз Вашей помощи, поскольку вопрос до конца далеко так и не решен.  
Касательно вопроса, от AutoFit пришлось отказаться, поскольку в Excel есть ограничение на ширину столбца, а именно 256 знаков.  
Пришлось по другому решать данную проблему - нашел соответствие между символом (Times New Roman 14) и его шириной.  
Function symbolicon(ByVal smb As String) As Double  
Dim dw As Double  
Select Case smb  
Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, _  
"g", "h", "k", "x", "c", "v", "y", "u", "n", _  
"у", "к", "х", "в", "л", "я", "с", "ь"  
dw = Round(420 / 62, 3)  
Case "q", "o", "p", "d", "b", _  
"й", "ц", "н", "ъ", "п", "р", "о", "д", "ч", "и", "б"  
dw = Round(420 / 56, 3)  
Case "j", "l", "i"  
dw = Round(420 / 140, 3)  
Case "z", "e", "a", "s", _  
"е", "г", "з", "а", "э", "т"  
dw = Round(420 / 70, 3)  
Case "w", _  
"ы", "ж"  
dw = Round(420 / 43, 3)  
Case "m", _  
"ш", "щ", "ю"  
dw = Round(420 / 40, 3)  
Case "r", "f"  
dw = Round(420 / 93, 3)  
Case "t"  
dw = Round(420 / 112, 3)  
End Select  
symbolicon = dw  
End Function  
а также составил процедуру переноса текста в зависивости от ширины, например задаем ширину 15 points (для более быстрого тестирования на правильность)  
Sub bgh3()  
Dim n As Double, i As Long, m As Long  
Dim j As Long, v As Long, lstr As Long  
Dim stroka As String, k As String, t As String  
lstr = Len(Cells(1, 1).Value)  
stroka = CStr(Cells(1, 1).Value)  
n = 0: i = 1: m = 1: j = 2: v = 1  
er:  
Do While i < lstr And n < 15  
k = Mid(stroka, i, 1)  
n = symbolicon(k) + n  
Cells(j, 1).Value = n  
i = i + 1: m = m + 1  
Loop  
t = Mid(stroka, v, m)  
Cells(j, 2).Value = t  
m = 1  
n = 0  
j = j + 1  
v = i + m  
If i < lstr Then  
GoTo er  
End If  
End Sub  
Например в ячейке Cells(1, 1) у меня текст    
tarassoktrezayatas  
процедура считает так  
taras - это правильно считает  
sokt -тоже правильно  
trez - неправильно, поскольку последний символ последней строки оказался первым.  
zaya - и т.д. и т.п.  
atas  
s  
 
а должно быть    
taras  
sokt  
rez... (и до следующего символа, чтобы было n<15)
 
 
 
#15
15.09.2012 17:27:28
Привет знатокам!  
После долгих раздумий, все-таки удалось составить макрос по переносу текста с учетом размерных соотношений (в points). Надеюсь, может кто-то даст дельные советы в плане оптимизации кода, так и возможно в алгоритме построения данной проблемы(например, возможно ли на Scripting.Dictionary такое сделать и как?)  
Своим вариантом поделюсь ниже, а также предоставлю файл, где есть коды и символьного переноса  
Sub perenosSTR()  
Dim n#, dl#, u%, i%, pos%, st%, m%  
Dim stroka$, k$, arrp(), arrs()  
dl = Cells(4, 2).Value  
stroka = CStr(Cells(1, 1).Value)  
u = Len(stroka)  
ReDim arrp(1 To u)  
ReDim arrs(1 To u)  
n = 0: j = 1: m = 1: st = 0: pos = 1  
err:  
For i = m To u Step 1  
k = Mid(stroka, i, 1)  
arrp(i) = symbolicon(k)  
arrs(i) = k  
n = arrp(i) + n  
If n > dl Then Exit For  
st = st + 1  
Next i  
If i < Len(stroka) Then  
a = n - arrp(i)  
End If  
If i >= Len(stroka) And st > 1 Then  
a = n  
End If  
If i >= Len(stroka) And st = 1 Then  
a = arrp(i - 1)  
End If  
Cells(j + 3, 3).Value = a  
Cells(j + 3, 4).Value = Mid(stroka, pos, st)  
b = Mid(stroka, pos, st)  
pos = pos + st  
n = 0: st = 0  
If i > Len(stroka) Then Exit Sub  
m = i  
j = j + 1  
GoTo err  
End Sub
 
 
 
#16
15.09.2012 17:32:26
:))
 
 
 
Страницы: 1
Читают тему
Наверх