0

Есть макрос на VBA.

Sub copyTable()
Dim colRange As Variant
colRange = Array(1, 2, 3, 4, 5, 6, 7) 'Columns where your data is'
Dim destColRange As Variant
destColRange = Array(10, 11, 12, 13, 14, 15, 16, 17) 'Columns where you want 
data be copied'
n = UBound(colRange) - LBound(colRange)
i = 2 'Initial row'
newI = i
maxLen = 500 'Maximum size allowed in one cell'
While Not (Cells(i, colRange(0)) Is Nothing) And (Cells(i, colRange(0)) <> 
"")
    Text = Cells(i, colRange(n))
    Do
        For j = 0 To n - 1
            Cells(newI, destColRange(j)) = Cells(i, colRange(j))
        Next j
        Cells(newI, destColRange(j)) = Mid(Text, 1, maxLen)
        Text = Mid(Text, maxLen + 1)
        newI = newI + 1
    Loop Until Len(Text) <= 0
    i = i + 1
Wend
End Sub

Если в ячейке последнеего столбца текст длиной более 500 символов, то остаток символов переносится на строку ниже с дублированием других ячеек строки.

Подскажите, как сделать, чтобы все это делалось не для последнего столбца, а, к примеру, для предпоследнего (в данном случае 6).

1 ответ 1

1

n - номер проверяемого толбца.

UBound(colRange), LBound(colRange) - наибольший и наименьший индексы массива. В одномерном массиве по умолчанию индексы начинаются с нуля.

Сейчас в n- предпоследний столбец

Ниже подправленный код с объявлением переменных

Sub copyTable()
Dim colRange(), destColRange()
Dim Text As String
Dim i As Long, newI As Long, n As Long, j As Long
Dim maxLen As Long
    colRange = Array(1, 2, 3, 4, 5, 6, 7) 'Columns where your data is'
    destColRange = Array(10, 11, 12, 13, 14, 15, 16, 17) 'Columns where you want
    'data be copied'
    n = UBound(colRange) - LBound(colRange)-1
    i = 2 'Initial row'
    newI = i
    maxLen = 500 'Maximum size allowed in one cell'

    While Not (Cells(i, colRange(0)) Is Nothing) And (Cells(i, colRange(0)) <> "")
        Text = Cells(i, colRange(n))

        Do
            For j = 0 To n - 1
                Cells(newI, destColRange(j)) = Cells(i, colRange(j))
            Next j

            Cells(newI, destColRange(j)) = Mid(Text, 1, maxLen)
            Text = Mid(Text, maxLen + 1)
            newI = newI + 1
        Loop Until Len(Text) <= 0

        i = i + 1
    Wend
End Sub
2
  • Спасибо за разъяснение.
    – Furianec
    28 ноя 2017 в 10:16
  • А можно еще 1 вопрос? А как записать это не диапазон, а на другую страницу?
    – Furianec
    29 ноя 2017 в 13:06

Ваш ответ

Нажимая на кнопку «Отправить ответ», вы соглашаетесь с нашими условиями использования и подтверждаете, что прочитали и поняли наши политику конфиденциальности и нормы поведения.

Всё ещё ищете ответ? Посмотрите другие вопросы с метками или задайте свой вопрос.