Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Перенос длинного предложения со смещением строки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Перенос длинного предложения со смещением строки (Формулы/Formulas)
Перенос длинного предложения со смещением строки
regkmf Дата: Пятница, 01.04.2016, 13:21 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Товарищи, помогите пож решить проблему, думаю без макроса тут не обойтись
В примере на вкладке "Дано" есть список адресов, как сделать так чтоб этот список по достижении 55 символов переносил не умещающееся слово на следующую строку как показано на вкладке "Результат"?
К сообщению приложен файл: 2866148.xlsx (11.7 Kb)
 
Ответить
СообщениеТоварищи, помогите пож решить проблему, думаю без макроса тут не обойтись
В примере на вкладке "Дано" есть список адресов, как сделать так чтоб этот список по достижении 55 символов переносил не умещающееся слово на следующую строку как показано на вкладке "Результат"?
Автор - regkmf
Дата добавления - 01.04.2016 в 13:21
dima_dan2012 Дата: Пятница, 01.04.2016, 14:56 | Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 8 ±
Замечаний: 0% ±

Excel 2003,2007
Здравствуйте! Как-то так))

[vba]
Код

Sub test1()
    Dim i As Integer
    Dim Sht As String
        Y = 2
        i = 2
ASD = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Set Dano = ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(2)
       .[A1].CurrentRegion.Offset(1).ClearContents
While Y <= ASD
    
        .Range("a" & i).Value = Dano.Range("a" & Y).Value
        .Range("b" & i).Value = Dano.Range("a" & Y).Offset(, 1)
        .Range("d" & i).Value = Dano.Sheets(1).Range("a" & Y).Offset(, 3)
        If Len(Dano.Range("a" & Y).Offset(, 2)) >= 55 Then
            
            For A = 1 To Len(Dano.Range("a" & Y).Offset(, 2)) Step 55
            
                        B = Mid(Dano.Range("a" & Y).Offset(, 2), A, 55)
                
                .Range("c" & i).Value = B
                i = i + 1
            Next A
            Else
            
            .Range("c" & i).Value = Dano.Range("a" & Y).Offset(, 2)
            i = i + 1
            End If
    End With
Y = Y + 1
Loop
End Sub
[/vba]
[p.s.] немного облагородил свой сапожок;)
К сообщению приложен файл: 2866148_MY_12.xlsm (22.2 Kb)

WM :Z116994103939

Сообщение отредактировал dima_dan2012 - Пятница, 01.04.2016, 22:16
 
Ответить
СообщениеЗдравствуйте! Как-то так))

[vba]
Код

Sub test1()
    Dim i As Integer
    Dim Sht As String
        Y = 2
        i = 2
ASD = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Set Dano = ThisWorkbook.Sheets(1)
With ThisWorkbook.Sheets(2)
       .[A1].CurrentRegion.Offset(1).ClearContents
While Y <= ASD
    
        .Range("a" & i).Value = Dano.Range("a" & Y).Value
        .Range("b" & i).Value = Dano.Range("a" & Y).Offset(, 1)
        .Range("d" & i).Value = Dano.Sheets(1).Range("a" & Y).Offset(, 3)
        If Len(Dano.Range("a" & Y).Offset(, 2)) >= 55 Then
            
            For A = 1 To Len(Dano.Range("a" & Y).Offset(, 2)) Step 55
            
                        B = Mid(Dano.Range("a" & Y).Offset(, 2), A, 55)
                
                .Range("c" & i).Value = B
                i = i + 1
            Next A
            Else
            
            .Range("c" & i).Value = Dano.Range("a" & Y).Offset(, 2)
            i = i + 1
            End If
    End With
Y = Y + 1
Loop
End Sub
[/vba]
[p.s.] немного облагородил свой сапожок;)
Автор - dima_dan2012
Дата добавления - 01.04.2016 в 14:56
Manyasha Дата: Пятница, 01.04.2016, 17:20 | Сообщение № 3
Группа: Модераторы
Ранг: Старожил
Сообщений: 2198
Репутация: 898 ±
Замечаний: 0% ±

Excel 2010, 2016
а мне вот так придумалось )
[vba]
Код
Sub splitStr()
    Application.ScreenUpdating = False
    Dim lr&, nRow&, strFull$
    Set sh1 = ThisWorkbook.Sheets("Дано")
    lr = sh1.Cells(Rows.Count, "c").End(xlUp).Row: nRow = 2
    Dim part As String * 55
    With ThisWorkbook.Sheets("Результат")
        .[A1].CurrentRegion.Offset(1).ClearContents
        For i = 2 To lr
            .Cells(nRow, 1) = sh1.Cells(i, 1): .Cells(nRow, 2) = sh1.Cells(i, 2)
            strFull = sh1.Cells(i, 3)
            Do
                part = Trim(strFull)
                .Cells(nRow, 3) = part
                strFull = Replace(strFull, Trim(part), "")
                nRow = nRow + 1
            Loop While (Trim(strFull) <> "")
        Next i
    End With
End Sub
[/vba]
К сообщению приложен файл: 2866148_1.xlsm (21.2 Kb)

ЯД: 410013299366744 WM: R193491431804
 
Ответить
Сообщениеа мне вот так придумалось )
[vba]
Код
Sub splitStr()
    Application.ScreenUpdating = False
    Dim lr&, nRow&, strFull$
    Set sh1 = ThisWorkbook.Sheets("Дано")
    lr = sh1.Cells(Rows.Count, "c").End(xlUp).Row: nRow = 2
    Dim part As String * 55
    With ThisWorkbook.Sheets("Результат")
        .[A1].CurrentRegion.Offset(1).ClearContents
        For i = 2 To lr
            .Cells(nRow, 1) = sh1.Cells(i, 1): .Cells(nRow, 2) = sh1.Cells(i, 2)
            strFull = sh1.Cells(i, 3)
            Do
                part = Trim(strFull)
                .Cells(nRow, 3) = part
                strFull = Replace(strFull, Trim(part), "")
                nRow = nRow + 1
            Loop While (Trim(strFull) <> "")
        Next i
    End With
End Sub
[/vba]
Автор - Manyasha
Дата добавления - 01.04.2016 в 17:20
regkmf Дата: Суббота, 02.04.2016, 08:00 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Manyasha, спасибо огромное, то что нужно!!!!
 
Ответить
СообщениеManyasha, спасибо огромное, то что нужно!!!!
Автор - regkmf
Дата добавления - 02.04.2016 в 08:00
regkmf Дата: Воскресенье, 03.04.2016, 00:00 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Ребят, а можно сделать так чтобы перенос на другую строку был по двум условиям: 1 по достижении 55 символов (это уже работает) 2. переносились бы целые слова. Например сейчас макрос работает так:
Запись 9. Республика Кабардино-Балкария, г. Нальчик, Боль
ничный городок "Дубки", противотуберкулезный диспансер

А желательно чтобы слова не рвались, а переносились целиком например так:
Запись 9. Республика Кабардино-Балкария, г. Нальчик,
Больничный городок "Дубки", противотуберкулезный диспансер


Сообщение отредактировал regkmf - Воскресенье, 03.04.2016, 00:01
 
Ответить
СообщениеРебят, а можно сделать так чтобы перенос на другую строку был по двум условиям: 1 по достижении 55 символов (это уже работает) 2. переносились бы целые слова. Например сейчас макрос работает так:
Запись 9. Республика Кабардино-Балкария, г. Нальчик, Боль
ничный городок "Дубки", противотуберкулезный диспансер

А желательно чтобы слова не рвались, а переносились целиком например так:
Запись 9. Республика Кабардино-Балкария, г. Нальчик,
Больничный городок "Дубки", противотуберкулезный диспансер
Автор - regkmf
Дата добавления - 03.04.2016 в 00:00
StoTisteg Дата: Воскресенье, 03.04.2016, 00:36 | Сообщение № 6
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Можно попробовать так:
[vba]
Код
Sub splitStr()

    Application.ScreenUpdating = False
    Dim lr&, nRow&, strFull$
    Set sh1 = ThisWorkbook.Sheets("Дано")
    lr = sh1.Cells(Rows.Count, "c").End(xlUp).Row: nRow = 2
    Dim part As String * 55
    With ThisWorkbook.Sheets("Результат")
        .[A1].CurrentRegion.Offset(1).ClearContents
        For i = 2 To lr
            .Cells(nRow, 1) = sh1.Cells(i, 1): .Cells(nRow, 2) = sh1.Cells(i, 2)
            strFull = sh1.Cells(i, 3)
            Do
                part = strFull
                If Right(part, 1) <> " " And Right(part, 1) <> "," And Right(part, 1) <> "." And Right(part, 1) <> "-" Then
                    j = 0
                    Do
                        j = InStr(j + 1, part, " ", vbTextCompare)
                    Loop While InStr(j + 1, part, " ", vbTextCompare) <> 0
                    part = Left(part, j)
                End If
                part = Trim(part)
                .Cells(nRow, 3) = part
                strFull = Replace(strFull, Trim(part), "")
                nRow = nRow + 1
            Loop While (Trim(strFull) <> "")
        Next i
    End With
    
End Sub
[/vba]
не проверял, но должно работать... Проверил, работает

Интуитивно понятный код - это когда интуитивно понятно, что это код.

Сообщение отредактировал StoTisteg - Воскресенье, 03.04.2016, 12:17
 
Ответить
СообщениеМожно попробовать так:
[vba]
Код
Sub splitStr()

    Application.ScreenUpdating = False
    Dim lr&, nRow&, strFull$
    Set sh1 = ThisWorkbook.Sheets("Дано")
    lr = sh1.Cells(Rows.Count, "c").End(xlUp).Row: nRow = 2
    Dim part As String * 55
    With ThisWorkbook.Sheets("Результат")
        .[A1].CurrentRegion.Offset(1).ClearContents
        For i = 2 To lr
            .Cells(nRow, 1) = sh1.Cells(i, 1): .Cells(nRow, 2) = sh1.Cells(i, 2)
            strFull = sh1.Cells(i, 3)
            Do
                part = strFull
                If Right(part, 1) <> " " And Right(part, 1) <> "," And Right(part, 1) <> "." And Right(part, 1) <> "-" Then
                    j = 0
                    Do
                        j = InStr(j + 1, part, " ", vbTextCompare)
                    Loop While InStr(j + 1, part, " ", vbTextCompare) <> 0
                    part = Left(part, j)
                End If
                part = Trim(part)
                .Cells(nRow, 3) = part
                strFull = Replace(strFull, Trim(part), "")
                nRow = nRow + 1
            Loop While (Trim(strFull) <> "")
        Next i
    End With
    
End Sub
[/vba]
не проверял, но должно работать... Проверил, работает
Автор - StoTisteg
Дата добавления - 03.04.2016 в 00:36
regkmf Дата: Воскресенье, 03.04.2016, 11:17 | Сообщение № 7
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
StoTisteg, все равно слова разрывает :(
 
Ответить
СообщениеStoTisteg, все равно слова разрывает :(
Автор - regkmf
Дата добавления - 03.04.2016 в 11:17
StoTisteg Дата: Воскресенье, 03.04.2016, 12:11 | Сообщение № 8
Группа: Авторы
Ранг: Старожил
Сообщений: 1161
Репутация: 103 ±
Замечаний: 0% ±

Excel 2010
Да, не дело это — среди ночи код писать :( Право с левом перепутал... Исправил, проверил, теперь работает.

Интуитивно понятный код - это когда интуитивно понятно, что это код.
 
Ответить
СообщениеДа, не дело это — среди ночи код писать :( Право с левом перепутал... Исправил, проверил, теперь работает.
Автор - StoTisteg
Дата добавления - 03.04.2016 в 12:11
regkmf Дата: Воскресенье, 03.04.2016, 13:42 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
StoTisteg, благодарю!
 
Ответить
СообщениеStoTisteg, благодарю!
Автор - regkmf
Дата добавления - 03.04.2016 в 13:42
Мир MS Excel » Вопросы и решения » Вопросы по Excel » Перенос длинного предложения со смещением строки (Формулы/Formulas)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!