Копирование по значению ячейки на другой лист
ann_tamb
Дата: Понедельник, 25.04.2022, 09:44 |
Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация:
0
±
Замечаний:
0% ±
Здравствуйте, подскажите пожалуйста, необходимо копировать все строки с листа ПЕРЕЧЕНЬ на лист Иванов если в графе 6 указана фамилия Иванов. Моя проблема в том, что копирование идет только по значению "Иванов", а если данная фамилия встречается в ячейке с другими (разделитель - Enter), то копирование не происходит. Пример прилагаю. Помогите пожалуйста (никак не дойду до истины).
[vba]
Код
Sub Del_SubStr() Dim sSubStr As String Dim lCol As Long Dim lLastRow As Long, li As Long, x As Long, y As Long Dim arr Application.EnableEvents = False Application.ScreenUpdating = False x = ActiveCell.Row y = ActiveCell.Column Sheets("Перечень").Select Columns("A:I").Select Selection.Copy Sheets("Иванов").Select Columns("A:A").Select ActiveSheet.Paste sSubStr = "Иванов" lCol = 6 lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count arr = Cells(1, lCol).Resize(lLastRow).Value Dim rr As Range For li = 2 To lLastRow If CStr(arr(li, 1)) <> sSubStr Then If rr Is Nothing Then Set rr = Cells(li, 1) Else Set rr = Union(rr, Cells(li, 1)) End If End If Next li If Not rr Is Nothing Then rr.EntireRow.Delete Sheets("Перечень").Select Selection.Cells(x, y).Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
[/vba]
[moder]исправлено[/moder]
Здравствуйте, подскажите пожалуйста, необходимо копировать все строки с листа ПЕРЕЧЕНЬ на лист Иванов если в графе 6 указана фамилия Иванов. Моя проблема в том, что копирование идет только по значению "Иванов", а если данная фамилия встречается в ячейке с другими (разделитель - Enter), то копирование не происходит. Пример прилагаю. Помогите пожалуйста (никак не дойду до истины).
[vba]
Код
Sub Del_SubStr() Dim sSubStr As String Dim lCol As Long Dim lLastRow As Long, li As Long, x As Long, y As Long Dim arr Application.EnableEvents = False Application.ScreenUpdating = False x = ActiveCell.Row y = ActiveCell.Column Sheets("Перечень").Select Columns("A:I").Select Selection.Copy Sheets("Иванов").Select Columns("A:A").Select ActiveSheet.Paste sSubStr = "Иванов" lCol = 6 lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count arr = Cells(1, lCol).Resize(lLastRow).Value Dim rr As Range For li = 2 To lLastRow If CStr(arr(li, 1)) <> sSubStr Then If rr Is Nothing Then Set rr = Cells(li, 1) Else Set rr = Union(rr, Cells(li, 1)) End If End If Next li If Not rr Is Nothing Then rr.EntireRow.Delete Sheets("Перечень").Select Selection.Cells(x, y).Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
[/vba]
[moder]исправлено[/moder] ann_tamb
Сообщение отредактировал ann_tamb - Понедельник, 25.04.2022, 12:27
Ответить
Сообщение Здравствуйте, подскажите пожалуйста, необходимо копировать все строки с листа ПЕРЕЧЕНЬ на лист Иванов если в графе 6 указана фамилия Иванов. Моя проблема в том, что копирование идет только по значению "Иванов", а если данная фамилия встречается в ячейке с другими (разделитель - Enter), то копирование не происходит. Пример прилагаю. Помогите пожалуйста (никак не дойду до истины).
[vba]
Код
Sub Del_SubStr() Dim sSubStr As String Dim lCol As Long Dim lLastRow As Long, li As Long, x As Long, y As Long Dim arr Application.EnableEvents = False Application.ScreenUpdating = False x = ActiveCell.Row y = ActiveCell.Column Sheets("Перечень").Select Columns("A:I").Select Selection.Copy Sheets("Иванов").Select Columns("A:A").Select ActiveSheet.Paste sSubStr = "Иванов" lCol = 6 lLastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count arr = Cells(1, lCol).Resize(lLastRow).Value Dim rr As Range For li = 2 To lLastRow If CStr(arr(li, 1)) <> sSubStr Then If rr Is Nothing Then Set rr = Cells(li, 1) Else Set rr = Union(rr, Cells(li, 1)) End If End If Next li If Not rr Is Nothing Then rr.EntireRow.Delete Sheets("Перечень").Select Selection.Cells(x, y).Select Application.ScreenUpdating = True Application.EnableEvents = True End Sub
[/vba]
[moder]исправлено[/moder] Автор - ann_tamb Дата добавления - 25.04.2022 в 09:44
китин
Дата: Понедельник, 25.04.2022, 09:52 |
Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 7029
Репутация:
1078
±
Замечаний:
0% ±
Excel 2007;2010;2016
ann_tamb , - Прочитайте Правила форума - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку # , пояснялка здесь )
ann_tamb , - Прочитайте Правила форума - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку # , пояснялка здесь )китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Ответить
Сообщение ann_tamb , - Прочитайте Правила форума - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку # , пояснялка здесь )Автор - китин Дата добавления - 25.04.2022 в 09:52
msi2102
Дата: Понедельник, 25.04.2022, 13:05 |
Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 415
Репутация:
129
±
Замечаний:
0% ±
Excel 2007
Замените строку [vba]Код
If CStr(arr(li, 1)) <> sSubStr Then
[/vba] на такую [vba]Код
If Not CStr(arr(li, 1)) Like "*" & sSubStr & "*" Then
[/vba] или такую [vba]Код
If InStr(1, CStr(arr(li, 1)), sSubStr) = 0 Then
[/vba]
Замените строку [vba]Код
If CStr(arr(li, 1)) <> sSubStr Then
[/vba] на такую [vba]Код
If Not CStr(arr(li, 1)) Like "*" & sSubStr & "*" Then
[/vba] или такую [vba]Код
If InStr(1, CStr(arr(li, 1)), sSubStr) = 0 Then
[/vba] msi2102
Сообщение отредактировал msi2102 - Понедельник, 25.04.2022, 14:52
Ответить
Сообщение Замените строку [vba]Код
If CStr(arr(li, 1)) <> sSubStr Then
[/vba] на такую [vba]Код
If Not CStr(arr(li, 1)) Like "*" & sSubStr & "*" Then
[/vba] или такую [vba]Код
If InStr(1, CStr(arr(li, 1)), sSubStr) = 0 Then
[/vba] Автор - msi2102 Дата добавления - 25.04.2022 в 13:05
китин
Дата: Понедельник, 25.04.2022, 13:18 |
Сообщение № 4
Группа: Модераторы
Ранг: Экселист
Сообщений: 7029
Репутация:
1078
±
Замечаний:
0% ±
Excel 2007;2010;2016
msi2102 , простите, а с какого переляка вы замечания модератора игнорируете? или вы просто их не видите?
msi2102 , простите, а с какого переляка вы замечания модератора игнорируете? или вы просто их не видите?китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Ответить
Сообщение msi2102 , простите, а с какого переляка вы замечания модератора игнорируете? или вы просто их не видите?Автор - китин Дата добавления - 25.04.2022 в 13:18
msi2102
Дата: Понедельник, 25.04.2022, 13:39 |
Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 415
Репутация:
129
±
Замечаний:
0% ±
Excel 2007
вы замечания модератора игнорируете
Извиняюсь, думал он исправил, просто у меня косяк при отображении, сейчас отредактирую
вы замечания модератора игнорируете
Извиняюсь, думал он исправил, просто у меня косяк при отображении, сейчас отредактируюmsi2102
Сообщение отредактировал msi2102 - Понедельник, 25.04.2022, 13:41
Ответить
Сообщение вы замечания модератора игнорируете
Извиняюсь, думал он исправил, просто у меня косяк при отображении, сейчас отредактируюАвтор - msi2102 Дата добавления - 25.04.2022 в 13:39
китин
Дата: Понедельник, 25.04.2022, 14:27 |
Сообщение № 6
Группа: Модераторы
Ранг: Экселист
Сообщений: 7029
Репутация:
1078
±
Замечаний:
0% ±
Excel 2007;2010;2016
msi2102 , написал вам, как можно исправить ваш код. у меняя код другой [vba]Код
Sub Макрос2() ii_ = Sheets("ПЕРЕЧЕНЬ").Cells(Rows.Count, 1).End(xlUp).Row Sheets("ПЕРЕЧЕНЬ").Range("$A$1:$I$" & ii_).AutoFilter Field:=6, Criteria1:="Иванов*" Range("A2:I" & ii_).SpecialCells(xlCellTypeVisible).Copy Sheets("Иванов").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("ПЕРЕЧЕНЬ").Range("$A$1:$I$" & ii_).AutoFilter Field:=6 End Sub
[/vba]
msi2102 , написал вам, как можно исправить ваш код. у меняя код другой [vba]Код
Sub Макрос2() ii_ = Sheets("ПЕРЕЧЕНЬ").Cells(Rows.Count, 1).End(xlUp).Row Sheets("ПЕРЕЧЕНЬ").Range("$A$1:$I$" & ii_).AutoFilter Field:=6, Criteria1:="Иванов*" Range("A2:I" & ii_).SpecialCells(xlCellTypeVisible).Copy Sheets("Иванов").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("ПЕРЕЧЕНЬ").Range("$A$1:$I$" & ii_).AutoFilter Field:=6 End Sub
[/vba]китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Ответить
Сообщение msi2102 , написал вам, как можно исправить ваш код. у меняя код другой [vba]Код
Sub Макрос2() ii_ = Sheets("ПЕРЕЧЕНЬ").Cells(Rows.Count, 1).End(xlUp).Row Sheets("ПЕРЕЧЕНЬ").Range("$A$1:$I$" & ii_).AutoFilter Field:=6, Criteria1:="Иванов*" Range("A2:I" & ii_).SpecialCells(xlCellTypeVisible).Copy Sheets("Иванов").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Sheets("ПЕРЕЧЕНЬ").Range("$A$1:$I$" & ii_).AutoFilter Field:=6 End Sub
[/vba]Автор - китин Дата добавления - 25.04.2022 в 14:27
ann_tamb
Дата: Вторник, 26.04.2022, 14:00 |
Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация:
0
±
Замечаний:
0% ±
msi2102 , китин , спасибо огромное! Извиняюсь за неправильное оформление. Спасибо, что исправили , а не удалили)
msi2102 , китин , спасибо огромное! Извиняюсь за неправильное оформление. Спасибо, что исправили , а не удалили)ann_tamb
Сообщение отредактировал ann_tamb - Вторник, 26.04.2022, 17:00
Ответить
Сообщение msi2102 , китин , спасибо огромное! Извиняюсь за неправильное оформление. Спасибо, что исправили , а не удалили)Автор - ann_tamb Дата добавления - 26.04.2022 в 14:00