Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Перенос значений по условию на другой Лист
 
#1
07.05.2023 04:03:34

Здравствуйте! Помогите пожалуйста разобраться с кодом.

Если на Листе "Пример" в столбце "В" значение начинается с "8*" (другие символы и значения, начиная со второго не имеют значения), то значение из столбца "L" перенести (скопировать и вставить) на Лист "Тест" в столбец "H", в противном случае значение из столбца "L" перенести (скопировать и вставить) на Лист "Тест" в столбец "R". Макрос есть но работает только для проверки "Если на Листе "Пример" в столбце "В" значение начинается с "8*" . Если вставляю в код 'ElseIf Cells(i, 2) <> "8*" Then, то получается ерунда.

Изменено: RMG - 07.05.2023 04:03:59
 
 
 
#2
07.05.2023 13:03:12
Здравствуйте.
Код
Sub CopyCells()
    Dim i As Long, nextRowH As Long, nextRowR As Long, lastRowPrimer As Long
    lastRowPrimer = Worksheets("Пример").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Тест").Range("A2:H100").ClearContents
    Worksheets("Тест").Range("K2:R100").ClearContents
    Application.ScreenUpdating = False
    For i = 5 To lastRowPrimer
        If Worksheets("Пример").Cells(i, 2) Like "8*" Then
            nextRowH = Worksheets("Тест").Cells(Rows.Count, "H").End(xlUp).Row + 1
            Worksheets("Пример").Range("L" & i).Copy Destination:=Worksheets("Тест").Range("H" & nextRowH)
        Else
            nextRowR = Worksheets("Тест").Cells(Rows.Count, 2).End(xlUp).Row + 1
            Worksheets("Пример").Range("L" & i).Copy Destination:=Worksheets("Тест").Range("R" & nextRowR)
        End If
    Next i
End Sub
 
 
 
#3
07.05.2023 13:54:07
DANIKOLA Чудо! Все великолепно работает! Спасибо огромное!
 
 
 
#4
08.05.2023 04:13:32
DANIKOLA Добрый день! Можно попросить изменить макрос под другие условия, пожалуйста.
Если на Листе "Пример" в столбце "N" есть значение, то ячейки "C:G"
скопировать  на Лист "Тест" в ячейки "A:E",
если есть значение в столбце "O", то ячейки "I:M" скопировать  на Лист "Тест" в ячейки "K:O".
На Листе "Результат" то, что хотелось бы получить.
Пыталась Ваш макрос изменить у меня не получилось.  
 
 
 
#5
08.05.2023 08:28:08
Код
Dim i As Long, RowH As Long, RowR As Long
    lastRow = Worksheets("Пример").Cells(Rows.Count, 2).End(xlUp).Row
    
    For i = 2 To lastRow
        If Worksheets("Пример").Cells(i, 3) Like "8*" Or Worksheets("Пример").Cells(i, 10) Like "8*" Then
            RowH = Worksheets("Тест").Cells(Rows.Count, "A").End(xlUp).Row + 1
            Worksheets("Пример").Range("C" & i & ":G" & i).Copy Destination:=Worksheets("Тест").Range("A" & RowH)
        Else
            RowR = Worksheets("Тест").Cells(Rows.Count, 2).End(xlUp).Row + 1
            Worksheets("Пример").Range("I" & i & ":M" & i).Copy Destination:=Worksheets("Тест").Range("K" & RowR)
        End If
    Next i
Вот так изменила Ваш код и у меня все вроде переносится, но цикл повторяется снова и снова. Что не так? :cry:  
 
 
 
#6
08.05.2023 21:13:20
Код
Sub CopyCells2()
    Dim i As Long, nextRowA As Long, nextRowK As Long, lastRowPrimer As Long
    lastRowPrimer = Worksheets("Пример").Cells(Rows.Count, 2).End(xlUp).Row
    Worksheets("Тест").Range("A2:H100").ClearContents
    Worksheets("Тест").Range("K2:R100").ClearContents
    Application.ScreenUpdating = False
    For i = 2 To lastRowPrimer
        If Worksheets("Пример").Cells(i, 14) <> "" Then
            nextRowA = Worksheets("Тест").Cells(Rows.Count, "A").End(xlUp).Row + 1
            Range(Worksheets("Пример").Cells(i, 3), Worksheets("Пример").Cells(i, 7)).Copy _
            Destination:=Worksheets("Тест").Range("A" & nextRowA)
        ElseIf Worksheets("Пример").Cells(i, 15) <> "" Then
            nextRowK = Worksheets("Тест").Cells(Rows.Count, "K").End(xlUp).Row + 1
            Range(Worksheets("Пример").Cells(i, 9), Worksheets("Пример").Cells(i, 13)).Copy _
            Destination:=Worksheets("Тест").Range("K" & nextRowK)
        End If
    Next i
End Sub

P.S. Думаю лучше не привязываться к конкретному пользователю, от этого у других пользователей способных помочь, пропадает желание даже смотреть на задачу.
 
 
 
#7
08.05.2023 21:21:46
А где
Код
Application.ScreenUpdating =True
 
 
 
#8
08.05.2023 22:26:53
Kuzmich, Application.ScreenUpdating =True, включается автоматически после выполнения макроса. Раше всегда его писал, а в одном видеоуроке увидел, что можно и без него обойтись, после этого перестал его писать и проблем никаких не замечал.
На этом канале смотрел.
 
 
 
#9
09.05.2023 03:25:42
DANIKOLA красиво!!! Спасибо огромное!
Kuzmich приятная встреча!!!
 
 
 
Страницы: 1
Наверх