Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Поиск данных в диапазонах трех листов и перенос их в ячейку листа
 
#1
13.08.2026 15:10:44
Добрый день, господа форумчане!
В диапазоне I9:I листа КАЛЕНДАРЬ макрос просматривает данные и сравнивает с данными ячеек диапазона Е6:Е листа Телефоны1 и, если есть совпадение, выводит это совпадение (ФИО сотрудника) в ячейку W16 .
Помогите дописать код, чтобы просматривались диапазоны трех листов одновременно!

Выкладываю xlsx, xlsm - не грузится никак. Вот код модуля листа КАЛЕНДАРЬ:
Код
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("I9:I" & Cells(Rows.Count, "I").End(xlUp).Row)) Is Nothing Then
  If Target.Count = 1 Then
    Application.ScreenUpdating = False
    Dim iCl_2 As Range
    For Each iCl_2 In Sheets("Телефоны1").Range("E6:E" & Sheets("Телефоны1").Cells(Sheets("Телефоны1").Rows.Count, "E").End(xlUp).Row)
      If Target.Value Like "*" & iCl_2 & "*" Then
        Range("W16").Value = iCl_2.Value
        Exit For
      End If
    Next
  End If
End If
Application.ScreenUpdating = True
End Sub

Заранее благодарен за помощь!






 
Изменено: evg_glaz - 13.08.2026 15:12:44
 
 
 
#2
13.08.2026 16:41:15
Здравствуйте.
Попробуйте так
Код
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("I9:I" & Cells(Rows.Count, "I").End(xlUp).Row)) Is Nothing Then
  If Target.Count = 1 Then
    Application.ScreenUpdating = False
    Dim iCl_2 As Range
    For i = 1 To 3
    For Each iCl_2 In Sheets("Телефоны" & i).Range("E6:E" & Sheets("Телефоны" & i).Cells(Sheets("Телефоны" & i).Rows.Count, "E").End(xlUp).Row)
      If Target.Value Like "*" & iCl_2 & "*" Then
        Range("W16").Value = iCl_2.Value
        Exit For
      End If
    Next
    Next
  End If
End If
Application.ScreenUpdating = True
End Sub
 
 
 
#3
13.08.2026 17:12:47
evg_glaz,
Такое можно и в PQ:
Код
let
    from = Excel.Workbook(File.Contents(путь), false, false),
    tbl = (nm)=> Table.Combine(Table.SelectRows(from, (x)=> x[Kind]="Sheet" and Text.Contains(x[Name], nm) )[Data]  ),
    names = 
        [names = tbl("Телефон"),
         prof = Table.Buffer(Table.Profile(names)),
         cols = Table.SelectRows(prof, (x)=> x[NullCount]=x[Count])[Column],
         remcols = Table.RemoveColumns(names, cols),
         tocols = Table.ToColumns(remcols),
         cmb = List.Combine(tocols),
         remnulls = List.RemoveNulls(cmb)][remnulls],
    clndr = 
        [clndr = tbl("КАЛЕНДАР"),
         tocols = List.Select(Table.ToColumns(clndr), (x)=> List.Contains(x, 9)),
         cmb = List.Combine(tocols),
         remitms = List.RemoveMatchingItems(cmb, {null, 9})][remitms],
    intrsct = List.Intersect({clndr, names})
    
     
in
    intrsct
Шлюхогон42
 
 
 
#4
14.08.2026 11:49:13
gling, Добрый день! Выдает ошибку (выделяет i)
Файл приложен для примера, листы на самом деле имеют разные названия, не "Телефоны1, 2, 3")
Код
For i = 1 To 3
Изменено: evg_glaz - 14.08.2026 11:52:37
 
 
 
#5
14.08.2026 11:50:24
Дмитрий Никитин, благодарю! Но нужен макрос. И не дружу с PQ от слова совсем)))
 
 
 
#6
14.08.2026 13:05:24
?
Скрытый текст
Согласие есть продукт при полном непротивлении сторон
 
 
 
#7
14.08.2026 15:01:30
Sanja, спасибо! Неожиданно просто и хитро!)
Хороших выходных!
 
 
 
#8
15.08.2026 11:18:55
Ещё вариант на основе кода от Sanja из поста #6
Код
Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim ws          As Worksheet
    Dim rng         As Range
    Dim arr         As Variant
    Dim i           As Long

    On Error GoTo ExitHandler
    If Target.CountLarge <> 1 Then Exit Sub

    Dim LastRow     As Long
    LastRow = Me.Cells(Me.Rows.Count, "I").End(xlUp).Row

    If Intersect(Target, Me.Range("I9:I" & LastRow)) Is Nothing Then Exit Sub

    Dim SearchText  As String
    SearchText = CStr(Target.Value2)
    If Len(SearchText) = 0 Then Exit Sub

    Application.ScreenUpdating = False

    For Each ws In ThisWorkbook.Worksheets

        If Not ws Is Me Then

            With ws
                LastRow = .Cells(.Rows.Count, "E").End(xlUp).Row

                If LastRow >= 6 Then
                    Set rng = .Range("E6:E" & LastRow)
                    arr = rng.Value2

                    For i = 1 To UBound(arr, 1)

                        If Len(arr(i, 1)) > 0 Then

                            If InStr(1, SearchText, CStr(arr(i, 1)), vbTextCompare) > 0 Then
                                Me.Range("W16").Value = arr(i, 1)
                                GoTo ExitHandler
                            End If

                        End If

                    Next i

                End If

            End With

        End If

    Next ws

ExitHandler:
    Application.ScreenUpdating = True
End Sub
 
 
 
Страницы: 1
Читают тему
Наверх