0

Имеется таблица с примерно такой структурой строк:

3начение_1 3начение_2 3начение_3 3начение_4 3начение_5  3начение_6 3начение_7
3начение_1 3начение_2
3начение_1
3начение_1 3начение_2 3начение_3
3начение_1 3начение_2 3начение_3 3начение_4 3начение_5  3начение_6 3начение_7
3начение_1 3начение_2
3начение_1

Нужно их сместить к такому виду:

3начение_1 3начение_2 3начение_3 3начение_4 3начение_5 3начение_6 3начение_7
                                                       3начение_1 3начение_2
                                                                  3начение_1
                                            3начение_1 3начение_2 3начение_3
3начение_1 3начение_2 3начение_3 3начение_4 3начение_5 3начение_6 3начение_7
                                                       3начение_1 3начение_2
                                                                  3начение_1

Вручную сместить можно, но если строк за тысячу и больше, то на это уйдет довольно много времени.

Как при помощи макроса реализовать подобный сдвиг?

2 ответа 2

1

Как-то так, без проверок и ограничений:

Sub OffsetData()
Dim rRng As Range, ArrData()
Dim lClmns As Long, lCnt As Long
Dim bFlag As Boolean
Dim i As Long, j As Long, p As Long, k As Long
    Set rRng = Application.InputBox("Выделить диапазон данных", "", , Type:=8)
    ArrData = rRng.Value: lClmns = UBound(ArrData, 2)

    For i = 1 To UBound(ArrData) ' по строкам
        k = 0: bFlag = False

        For j = lClmns - 1 To 1 Step -1 ' поиск первого правого значения
            If ArrData(i, j) <> Empty Then ' найдено первое правое значение
                For p = j To 1 Step -1 ' перенос значений
                    ArrData(i, lClmns - k) = ArrData(i, p) ' переносим значение
                    ArrData(i, p) = Empty ' удаляем значение
                    k = k + 1: bFlag = True
                Next p

                If bFlag Then Exit For ' переходим на следующую строку
            End If
        Next j
    Next i

    rRng.Value = ArrData
End Sub
1
Dim i As Integer, j As Integer
Dim ws As Worksheet
Dim maxColumn As Integer, valuesColumn As Integer

Set ws = ThisWorkbook.Worksheets("Нужный Лист")
maxColumn = ws.UsedRange.Columns.Count ' Максимальное кол-во столбцов
For i = 1 To ws.UsedRange.Rows.Count
    ' количество столбцов со значениями в текущей строке
    valuesColumn = WorksheetFunction.CountA(ws.Range(ws.Rows(i).Address))
    If valuesColumn < maxColumn Then
        For j = 1 To maxColumn - valuesColumn
            ws.Cells(i, 1).Insert shift:=xlToRight
        Next j
    End If
Next i

Set ws = Nothing
4
  • С UsedRange аккуратнее. UsedRange.Columns.Count покажет количество столбцов используемого диапазона листа, но не последний заполненный. Если данные расположены начиная с первого столбца, то ничего страшного, работать будет корректно. Еще возможная ошибка: если на листе, кроме нужных данных, есть другие заполненные столбцы. 29 авг 2016 в 22:09
  • @vikttur, наличие слева пустых столбцов никак не повлияет на работу макроса. А про наличие посторонней информации в задании нет ни слова.
    – Evrik
    30 авг 2016 в 5:23
  • Да я же не с претензией :) Так, узелок на память 30 авг 2016 в 6:56
  • @vikttur, я понял, может мой комментарий выглядит как-то резко, но это не так. Просто ответил без лишних слов на случай, если кому-то пригодится мой способ, но будут сомневаться после Вашего комментария.
    – Evrik
    30 авг 2016 в 12:01

Ваш ответ

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

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