0

Подскажите, как сохранить данные не в диапазон столбцов, а на другой лист?

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

1 ответ 1

1

Работа с объектами листа медленная. Переписал. Обработка в массивах. Добавлено копирование заголовков, определение размера диапазона данных.

Sub copyTable2()
Const lClmn As Long = 5 ' проверяемый столбец'
Const lMaxLen As Long = 20 ' допустимая длина текста'
Dim aData()
Dim sTxt As String
Dim lRw As Long
Dim i As Long, k As Long, j As Long
    With ActiveSheet
        lRw = .UsedRange.Rows.Count
        If lRw < 2 Then Exit Sub ' только шапка, данных нет'
        aData = .Range("A1:G" & lRw).Value ' данные в массив'
    End With

    For i = 2 To lRw
        ' определяем макс. возможное количество строк массива выгрузки'
        k = k + Int(Len(aData(i, lClmn)) / lMaxLen) + 1
    Next i

    ReDim aRes(1 To k, 1 To UBound(aData, 2)) ' задаем размерность масива выгрузки'
    k = 1
    For j = 1 To UBound(aData, 2): aRes(1, j) = aData(1, j): Next j ' копируем заголовки'

    For i = 2 To lRw
        If aData(i, 1) <> "" Then ' если в первом столбце не пусто'
            Do ' цикл, пока не выберем весь текст'
                k = k + 1

                For j = 1 To UBound(aData, 2)
                    aRes(k, j) = aData(i, j) ' копируем строку'
                Next j

                aRes(k, lClmn) = Left$(aData(i, lClmn), lMaxLen) ' часть текста в проверяемый столбец'
                aData(i, lClmn) = Mid$(aData(i, lClmn), lMaxLen + 1) ' обрезаем проверяемый текст'
            Loop While Len(aData(i, lClmn)) > 0 ' условие цикла - пока есть текст'
        End If
    Next i

    Application.ScreenUpdating = False

    With Worksheets("Лист3") ' лист для выгрузки'
        .UsedRange.Delete ' чистим лист перед выгрузкой'
        .Range("A1:G" & k).Value = aRes ' выгружаем результат на лист'
    End With

    Application.ScreenUpdating = True
    MsgBox "OK", 64, ""
End Sub
1
  • Благодарю за ответ.
    – Furianec
    4 дек 2017 в 5:37

Ваш ответ

By clicking “Отправить ответ”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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