Метод VBA excel перемещает ячейки в другую строку на основе значения

Я борюсь с методом VBA в excel. У меня есть CSV, который необходимо отредактировать в зависимости от категории продукта.

CSV выглядит следующим образом: Нажмите, чтобы просмотреть текущую таблицу

результат, которого я хочу добиться, таков: Нажмите, чтобы увидеть нужную таблицу

Вот метод, который я написал; Я думаю, что я близок, но пока не работает так, как хотелось бы.

Sub test()
    'c is a CELL or a range
    Dim c As Range

    'for each CELL in this range
    For Each c In Range("A2", Cells(Cells.SpecialCells(xlCellTypeLastCell).Row, 1))

        'Als de cel leeg is en de volgende niet dan
        If c = "" And c.Offset(1, 0) <> "" Then
            'verplaats inhoud lege cel naar 1 boven
            c.Offset(-1, 6) = c.Offset(0, 5)
            'Verwijder rij
            c.EntireRow.Delete       

        'Als de cel leeg is en de volgende ook dan
        ElseIf c = "" And c.Offset(1, 0) = "" Then
            'verplaats inhoud lege cel naar 1 boven
            If c.Offset(0, 5) <> "" Then
                c.Offset(-1, 6) = c.Offset(0, 5)

            'Als inhoud
            ElseIf c.Offset(1, 5) <> "" Then
                c.Offset(-1, 7) = c.Offset(1, 5)

            Else
                c.EntireRow.Delete
                c.Offset(1,0).EntireRow.Delete    
            End If

        End If
    Next
End Sub

В CSV есть несколько строк, которые совершенно пусты, поэтому это также необходимо учитывать.


excel vba
person CMBart    schedule 20.01.2017    source источник
comment
Итак, вопрос в том, как проверить, пуста ли вся строка ячейки c, если это правда, просто удалите строку, если нет других вещей. Это вопрос?   -  person A.S.H    schedule 20.01.2017

Ответы (2)


arrow_upward
2
arrow_downward

Я бы перебирал строки и проверял, заполнены ли две строки под каждой записью, а затем устанавливал значение записи в последнее заполненное значение. Затем вы можете разделить это значение, чтобы поместить значения в несколько столбцов.

Совет. При переборе ячеек и удалении строк всегда нужно начинать снизу и продвигаться вверх.

Попробуй это:

Sub test()

Dim arr() as String
Dim x As Long, i as long, lRow as long

With ThisWorkbook.Sheets("SheetName")
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row

    'Insert 2 columns to hold the extra information
    .Columns("E:F").Insert

    For x = lRow to 2 Step -1

        'Delete rows that are completely blank
        If .Cells(x, "A").Value = "" And .Cells(x, "D").Value = "" Then
            .Cells(x, "A").EntireRow.Delete

        'Find the next entry
        ElseIf .Cells(x, "A").Value <> "" Then

            'Check if the 2nd row below the entry is populated
            If .Cells(x + 2, "A").Value = "" And .Cells(x + 2, "D").Value <> "" Then
                .Cells(x, "D").Value = .Cells(x + 2, "D").Value
                .Range(.Cells(x + 2, "D"), .Cells(x + 1, "D")).EntireRow.Delete

                'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns
                arr = Split(.Cells(x, "D").Value, "/")
                For i = 0 to UBound(arr)
                    .Cells(x, 4 + i).Value = arr(i)
                Next i

            'If the 2nd row isn't populated only take the row below
            ElseIf .Cells(x + 1, "A").Value = "" And .Cells(x + 1, "D").Value <> "" Then
                .Cells(x, "D").Value = .Cells(x + 1, "D").Value
                .Cells(x + 1, "D").EntireRow.Delete

                'Split the strings using the "/" character, if there is also a space you will need to use "/ " instead, then populate the inserted columns
                arr = Split(.Cells(x, "D").Value, "/")
                For i = 0 to UBound(arr)
                    .Cells(x, 4 + i).Value = arr(i)
                Next i

            End If

        End If

    Next x

End With

End Sub
person Jordan    schedule 20.01.2017
comment
Написал преждевременно, сейчас заканчиваю - person Jordan; 20.01.2017
comment
Привет Джордан. Кажется, это работает для 1 продукта, после чего я получаю сообщение об ошибке Subscript out of range в следующей строке кода: .Cells(x, 4 + i).Value = arr(i) Любая идея? - person CMBart; 23.01.2017
comment
Извините, петли For i не нуждаются в петлях +1 на UBound(arr) - сейчас отредактировано. - person Jordan; 23.01.2017
comment
Работает! Вы, сэр, сэкономили мне много времени! Большое спасибо! - person CMBart; 23.01.2017

arrow_upward
0
arrow_downward

Вы можете переместить последние 2 столбца и использовать Text To Columns для разделения столбца:

Sub test() ': Cells.Delete: [A1:F1,A3:F3] = [{1,2,3,"a/b/c",7,8}] ' used for testing
    Dim rng As Range
    Set rng = Sheet1.UsedRange                 ' set the range here

    rng.Columns("E:F").Cut
    rng.Resize(, 2).Insert xlToRight  ' move the last 2 columns

    rng.Columns("D").TextToColumns OtherChar:="/" ' split the last column

    rng.SpecialCells(xlCellTypeConstants).EntireRow.Hidden = True ' hide non-empty rows
    rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete ' delete visible rows
    rng.EntireRow.Hidden = False ' un-hide the rows

    Set rng = rng.CurrentRegion
    rng.Resize(, 2).Cut    ' move the 2 columns back to the end
    rng.Resize(, 2).Offset(, rng.Columns.Count).Insert xlToRight
End Sub

Изображения заблокированы там, где я сейчас нахожусь, поэтому столбцы могут нуждаться в некоторой корректировке.

person Slai    schedule 20.01.2017