Страницы: 1
RSS
Перенести ячейки со значением на другой лист, если эти ячейки уникальные
 
Всем доброго времени суток! Ваш форум меня выручал не раз и я надеюсь на помощь. Данную тему найти не удалось=( Мне кажется, что решение простое, но я не могу до него дойти :sceptic:

Итак, я ожидаю от алгоритма:
1) Находит значение, которое отличается от предыдущего в диапазоне A:A, как пример: (IF(A2=А1;"ничего";"перенести строку А2 на новый лист в строку A2").
2) Переносит строку с этим значением на новый лист.
3) При переносе строки идут одна за другой (IF(A3=А2;"ничего";"перенести строку А3 на новый лист в строку A2+1 и тд").

Пока что наковырял под себя такой макрос (прикрепляю файл), который вставляет разрыв строки, по выбранному столбцу, где находит повтор.
 
Доброго и Вам.
Код
Sub CopyUnique()
    Dim Cell As Range, vRange As Range, vCollection As Collection, i As Long, Wsh1 As Worksheet, Wsh2 As Worksheet
    
    Application.ScreenUpdating = False
    Set vCollection = New Collection
    Set Wsh1 = Worksheets("Реальность")
    Set Wsh2 = Worksheets("Ожидание")
    Set vRange = Range(Wsh1.Cells(2, 2), Wsh1.Cells(2, 2).End(xlDown))
    
    On Error Resume Next
    For Each Cell In vRange
        vCollection.Add Cell.Value, Cell.Value
    Next Cell
    i = 1
    On Error GoTo 0
    
    For Each Cell In vRange
        If i > vCollection.Count Then Exit For
            If Cell.Value = vCollection.Item(i) Then
                Wsh1.Range(Cell.Offset(0, -1), Cell.Offset(0, 1)).Copy Wsh2.Range("A1").Offset(i, 0)
                i = i + 1
            End If
    Next Cell
End Sub
P.S. Отдельное спасибо Дмитрию(The_Prist) Щербакову за его замечательные статьи. Долго мучился с ошибкой Run-time error '1004', а как только глянул статью, за пол минуты понял свою ошибку.
 
Спасибо Вам за помощь, я думаю, что с Вашим макросом уже можно работать, но хочу попросить помочь мне кое что поправить.
Я бы хотел, чтобы уникальные значение именно вырезались, а не копировались. Видимо я плохо объяснил задачу.
То есть, как в данном примере на первом листе должны остаться такие ячейки:
3Ананас0,4
3Ананас0,4
6Банан1
6Банан1
Если я меняю .Copy на .Cut макрос вырезает все значения.. :cry:
Ну а на следующем листе хотелось бы увидеть уникальные значения, как
1Яблоко0,1
2Груша0,2
3Ананас0,4
4Апельсин0,2
5Гранат0,6
6Банан1
 
С циклом For Each Cut  не хочет работать, как нужно данном случае.
Код обновлен:
Код
Sub CutUnique()
    Dim Cell As Range, vRange As Range, vCollection As Collection
    Dim i As Long, j As Long, Wsh1 As Worksheet, Wsh2 As Worksheet, lastRow As Long
    
    Application.ScreenUpdating = False
    Set vCollection = New Collection
    Set Wsh1 = Worksheets("Реальность")
    Set Wsh2 = Worksheets("Ожидание")
    Set vRange = Range(Wsh1.Cells(2, 1), Wsh1.Cells(2, 1).End(xlDown))
    
    On Error Resume Next
    For Each Cell In vRange
        vCollection.Add Cell.Text, Cell.Text
    Next Cell
    
    On Error GoTo 0
    i = 1
    lastRow = Wsh1.Range("A2").End(xlDown).Row
    For j = 2 To lastRow
        If i > vCollection.Count Then Exit For
            If Wsh1.Cells(j, 1).Text = vCollection.Item(i) Then
                Range(Wsh1.Cells(j, 2).Offset(0, -1), Wsh1.Cells(j, 2).Offset(0, 1)).Cut Wsh2.Range("A1").Offset(i, 0)
                i = i + 1
            End If
    Next j
End Sub


UPD:
Цитата
Андрей Вайцеховский написал:
...но в моем понимании j должно равняться  нулю...
Это недопустимо, как же мы потом сможем обратиться к Cells(j, 1), там ноль нельзя ставить - это ведь номер строки.
Переделал как Вы хотели по первому столбцу.
Изменено: DANIKOLA - 23.01.2022 22:57:15 (Добавлен ответ)
 
Все как надо! Спасибо Вам большое. Не сочтте за наглость или глупость, но у меня не получается привести к желаемому виду..
Я бы хотел, чтоб все таки находило уникальное значение в первом столбце ( начиная с А2 )
Я поменял
Код
j = 2 To Wsh1.Range("B2").End(xlDown).Row

на
Код
j = 1 To Wsh1.Range("А2").End(xlDown).Row,

но в моем понимании j должно равняться  нулю, а выдает ошибку =(
Так же, если я просто сдвигаю текст путем добавления пустого столбца в рабочий лист ничего не происходит
 
Методом "тыка" я почти нащупал! Спасибо Вам огромное за помощь и внимание!  :D  
Страницы: 1
Наверх