Sheets("Лист1").Select
i = 12
For i = 12 To 100
If Not IsEmpty(Cells(i, 5)) Then
Sheets("Лист1").Select
Range("A" & i & " : F" & i).Select
Selection.Copy
Sheets("Лист2").Select
ActiveSheet.Paste
Else
End If
Next i
Макрос для прайса
Здравствуйте, раньше особо не приходилось сталкиваться с VBA, но сейчас вот потребовалось и хочу обратиться к вам за помошью.:confused:
Вопрос в том как зделать так, чтобы по определенному столбцу осуществлялся поиск значений и если оно есть, копируется вся строка на новый лист. Никак не поучается что-то, сильно не смейтесь, попробовал так, но безрезультатно:(
Или может я совсем не в ту степь полез?
Вопрос в том как зделать так, чтобы по определенному столбцу осуществлялся поиск значений и если оно есть, копируется вся строка на новый лист. Никак не поучается что-то, сильно не смейтесь, попробовал так, но безрезультатно:(
Код:
Или может я совсем не в ту степь полез?
Если нужен именно поиск с копированием, то :
Хотя можно просто отфильтровать нужный столбец и скопировать полученные результаты во второй рабочий лист, и для этого, даже не нужно использовать макросы.
Код:
Private Sub NewPrice()
Dim iSource As Worksheet
Dim iDestination As Worksheet
Dim iCell As Range, iAddress$, iRow&
With Application
.ScreenUpdating = False
.Calculation = xlManual
'и т.д. по необходимости
Set iSource = .ThisWorkbook.Worksheets(1) 'лист должен существовать
Set iDestination = .ThisWorkbook.Worksheets(2) '+ ячейки не должны быть защищены (вместе с листом)
Set iCell = iSource.Columns("E").Find _
(What:="Искомый_текст", LookIn:=xlValues, LookAt:=xlPart)
If Not iCell Is Nothing Then
iAddress = iCell.Address
Do
iRow = iRow + 1
iCell.EntireRow.Copy Destination:= _
iDestination.Columns("A").Rows(iRow)
Set iCell = iSource.Columns("E").FindNext(After:=iCell)
Loop While Not iCell Is Nothing And iCell.Address <> iAddress
End If
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
Dim iSource As Worksheet
Dim iDestination As Worksheet
Dim iCell As Range, iAddress$, iRow&
With Application
.ScreenUpdating = False
.Calculation = xlManual
'и т.д. по необходимости
Set iSource = .ThisWorkbook.Worksheets(1) 'лист должен существовать
Set iDestination = .ThisWorkbook.Worksheets(2) '+ ячейки не должны быть защищены (вместе с листом)
Set iCell = iSource.Columns("E").Find _
(What:="Искомый_текст", LookIn:=xlValues, LookAt:=xlPart)
If Not iCell Is Nothing Then
iAddress = iCell.Address
Do
iRow = iRow + 1
iCell.EntireRow.Copy Destination:= _
iDestination.Columns("A").Rows(iRow)
Set iCell = iSource.Columns("E").FindNext(After:=iCell)
Loop While Not iCell Is Nothing And iCell.Address <> iAddress
End If
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub
Хотя можно просто отфильтровать нужный столбец и скопировать полученные результаты во второй рабочий лист, и для этого, даже не нужно использовать макросы.
Спасибо огромное! А вот как поиск осуществить не по конкретному значению, а чтобы он искал любое в ячейке? т.е. если она не пустая...
Код:
Set iCell = iSource.Columns("E").Find(What:="*", LookIn:=xlValues)
'или xlFormulas - если Вас интересует ячейка,
'которая может содержать пустую строку ""
'или xlFormulas - если Вас интересует ячейка,
'которая может содержать пустую строку ""
Да, и перед копированием наверное имеет смысл очищать ячейки второго рабочего листа.
Отлично всё работает, а вот такой вопрос:
Как организовать цикл в котором бы просматривался например столбец "D", в ктором бы повторяющиеся строки удалялись, но не все подряд, а только выше стоящая одна, т.е. искалось бы определенное содержимое ячейки и сравнивалось с выше стоящей ячейкой и если они одинаковы, то удалялась бы вся верхняя строка, и так далее вниз по столбцу...
Как организовать цикл в котором бы просматривался например столбец "D", в ктором бы повторяющиеся строки удалялись, но не все подряд, а только выше стоящая одна, т.е. искалось бы определенное содержимое ячейки и сравнивалось с выше стоящей ячейкой и если они одинаковы, то удалялась бы вся верхняя строка, и так далее вниз по столбцу...
Код:
With ThisWorkbook.Worksheets(1)
For iRow = 100 To 3 Step -1
'указать свой номер последней строки или определять его программно
'первая строка должна содержать заголовок и удалять её не нужно
If CStr(.Cells(iRow, "D")) = CStr(.Cells(iRow - 1, "D")) Then
.Rows(iRow - 1).Delete
End If
Next
End With
For iRow = 100 To 3 Step -1
'указать свой номер последней строки или определять его программно
'первая строка должна содержать заголовок и удалять её не нужно
If CStr(.Cells(iRow, "D")) = CStr(.Cells(iRow - 1, "D")) Then
.Rows(iRow - 1).Delete
End If
Next
End With
Но Ваш алгоритм предполагает, что все повторяющиеся значения находятся в смежных ячейках, а это не всегда так, следовательно, перед удалением строк нужно производить ещё и сортировку. Да, и получить список уникальных значений можно проще, достаточно применить расширенный фильтр, установив опцию Уникальные значения, а затем скопировать полученный результат в другой лист.
А можно ли в этой строке задать условие не по любому одинаковому значению, а по определенному, например какое-нибудь слово "Количество" и чтобы искалось именно оно.
Код:
If CStr(.Cells(iRow, "D")) = CStr(.Cells(iRow - 1, "D")) Then
Можно, например, так :
Но если Вы хотите именно искать нужный текст, то :
Код:
If CStr(.Cells(iRow, "D")) = "Количество" And _
CStr(.Cells(iRow - 1, "D")) = "Количество" Then
.Rows(iRow - 1).Delete
End If
CStr(.Cells(iRow - 1, "D")) = "Количество" Then
.Rows(iRow - 1).Delete
End If
Но если Вы хотите именно искать нужный текст, то :
Код:
With ThisWorkbook.Worksheets(1).Range("D:D")
Dim iCell As Range
Set iCell = .Find(What:="Количество", LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=True)
'Используем строгое соответствие, т.е. осуществляем поиск
'текста Количество игнорируя при этом КОЛИЧЕСТВО
If Not iCell Is Nothing Then
iAddress$ = iCell.Address
Do
If iCell.Value = CStr(iCell.Item(0, 1).Value) Then
iCell.Item(0, 1).EntireRow.Delete
iAddress$ = iCell.Address
End If
Set iCell = .FindNext(After:=iCell)
Loop While Not iCell Is Nothing And iCell.Address <> iAddress$
End If
End With
Dim iCell As Range
Set iCell = .Find(What:="Количество", LookIn:=xlValues, _
LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=True)
'Используем строгое соответствие, т.е. осуществляем поиск
'текста Количество игнорируя при этом КОЛИЧЕСТВО
If Not iCell Is Nothing Then
iAddress$ = iCell.Address
Do
If iCell.Value = CStr(iCell.Item(0, 1).Value) Then
iCell.Item(0, 1).EntireRow.Delete
iAddress$ = iCell.Address
End If
Set iCell = .FindNext(After:=iCell)
Loop While Not iCell Is Nothing And iCell.Address <> iAddress$
End If
End With
Спасибо огромние за помощь, всё получилось отлично!;)