Доброе время суток уважаемые знатоки. Прошу помочь в решении такой задачи: Если диапазон А:А содержить значение из G1, и диапазон В:В содержить "да" то этих совпадающих строк (но не всех) копировать в указанную ячейку. Написал макрос. Но не понимаю почему он не даёт желаемый результат. Всё нормально работает для 1-го цикла. Во 2-м цикле макрос опять копирует в тот же ячейку как в 1-м цикле. Формулой могу это сделать. Но надо сделать макросом. Файл прилагается. Спасибо.
Код
Sub copirovat_cells()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
lr2 = Cells(Rows.Count, 11).End(xlUp).Row + 1
For i = 1 To lr
If Cells(i, 1) = Cells(1, 7) And Cells(i, 2) = "да" Then
'cells(lr2,"K")=cells(i,1)
Cells(i, 1).Copy Cells(lr2, "K")
Cells(i, 2).Copy Cells(lr2, "L")
Cells(i, 3).Copy Cells(lr2, "M")
Cells(i, 5).Copy Cells(lr2, "N")
End If
Next
End Sub
Здравствуйте. У вас lr2 не изменяется. Попробуйте записать так
Код
Sub copirovat_cells()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
'lr2 = Cells(Rows.Count, 11).End(xlUp).Row + 1
For i = 1 To lr
If Cells(i, 1) = Cells(1, 7) And Cells(i, 2) = "да" Then
lr2 = Cells(Rows.Count, 11).End(xlUp).Row + 1
'cells(lr2,"K")=cells(i,1)
Cells(i, 1).Copy Cells(lr2, "K")
Cells(i, 2).Copy Cells(lr2, "L")
Cells(i, 3).Copy Cells(lr2, "M")
Cells(i, 5).Copy Cells(lr2, "N")
End If
Next
End Sub
Или
Код
Sub copirovat_cells()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
If Cells(i, 1) = Cells(1, 7) And Cells(i, 2) = "да" Then
'cells(lr2,"K")=cells(i,1)
Cells(i, 1).Copy Cells(lr2, "K")
Cells(i, 2).Copy Cells(lr2, "L")
Cells(i, 3).Copy Cells(lr2, "M")
Cells(i, 5).Copy Cells(lr2, "N")
lr2=lr2+1
End If
Next
End Sub
abduvs77 написал: Во 2-м цикле макрос опять копируетв тот же ячейку как в 1-м цикле.
Не нашёл в Вашем макрос второго цикла. Да и не нужен он. Проверьте:
Код
Sub copirovat_cells()
Dim lr As Long, i As Long, FreeRow As Long, sWord As String
lr = Cells(Rows.Count, 1).End(xlUp).Row
sWord = Range("G1")
FreeRow = 2
Application.ScreenUpdating = False 'Отключили обновление экрана
For i = 2 To lr
If Cells(i, 1) = sWord Then
If Cells(i, 2) = "да" Then
Cells(FreeRow, 11) = sWord
Cells(FreeRow, 12) = Cells(i, 3)
Cells(FreeRow, 14) = Cells(i, 5)
FreeRow = FreeRow + 1
End If
End If
Next
Application.ScreenUpdating = True 'Включили
End Sub
Спасибо уважаемый gling, Вы точно указали на мою ошибку. lr2 не в правильном месте указал. Ну а уважаемый Юрий М, как всегда с новыми решениями. Спасибо Вам дорогие.
gling, может я не понимаю чего-то, но lr2 не указано во втором коду который Вы предложили:
Код
Sub copirovat_cells()
Dim lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lr
If Cells(i, 1) = Cells(1, 7) And Cells(i, 2) = "да" Then
'cells(lr2,"K")=cells(i,1)
Cells(i, 1).Copy Cells(lr2, "K")
Cells(i, 2).Copy Cells(lr2, "L")
Cells(i, 3).Copy Cells(lr2, "M")
Cells(i, 5).Copy Cells(lr2, "N")
lr2=lr2+1
End If
Next
End Sub
abduvs77 написал: во втором коду который Вы предложили:
Я предложил только изменять переменную по мере работы цикла, а код копировал Ваш и вы сами в нем не объявили эту переменную. Юрий М, написал код как правильно должно быть, объявил все переменные и строки упорядочил. На такой код и смотреть приятно и читать понятно, видно разделение процедур. У Вас и у меня строки начинаются где захотят, это как то не красиво. Берите пример не с меня, а с Юрий М, В макросах я не специалист, умею, но не много.