Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сравнение ячеек на 2-х листах и копирование при совпадении. - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сравнение ячеек на 2-х листах и копирование при совпадении. (Макросы/Sub)
Сравнение ячеек на 2-х листах и копирование при совпадении.
parovoznik Дата: Пятница, 16.11.2018, 14:38 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 262
Репутация: 15 ±
Замечаний: 0% ±

Excel 2007
Добрый день.
Имеется таблица Лист "реестр" о движении транспортных средств.
На листе "данные" имеется дислокация транспорта. Мне нужно сравнить столбцы(№ тр.средства) на листах и при совпадении с копировать строки на лист "реестр".
Сейчас перенос работает при помощи функции ВПР.
Возможно перенос решить через макрос?
К сообщению приложен файл: 9760370.xlsm(17.9 Kb)
 
Ответить
СообщениеДобрый день.
Имеется таблица Лист "реестр" о движении транспортных средств.
На листе "данные" имеется дислокация транспорта. Мне нужно сравнить столбцы(№ тр.средства) на листах и при совпадении с копировать строки на лист "реестр".
Сейчас перенос работает при помощи функции ВПР.
Возможно перенос решить через макрос?

Автор - parovoznik
Дата добавления - 16.11.2018 в 14:38
doober Дата: Пятница, 16.11.2018, 21:32 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 512
Репутация: 231 ±
Замечаний: 0% ±

Excel 2007
Здравствуйте.
Чем ВПР провинилась?[vba]
Код
Sub AutoShape20_Щелчок()
    Dim rng As Range
    Set C_is = CreateObject("scripting.dictionary")
    With ThisWorkbook.Worksheets("данные")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("B1:F" & LastRow)
        For i = 1 To rng.Rows.Count
            Key = rng(i, 1).Offset(0, -1) & ""
            If Key <> "" Then
                Set C_is.Item(Key) = rng.Rows(i)
            End If
        Next
    End With
    With ThisWorkbook.Worksheets("реестр")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        dx = .Range("a1:a" & LastRow)
        .Range("g6:k" & LastRow).ClearContents
        For i = 6 To UBound(dx)
            Key = dx(i, 1) & ""
            If Key <> "" Then
                If C_is.Exists(Key) Then
                    C_is.Item(Key).Copy .Range("g" & i)
                End If
            End If
        Next
    End With
End Sub
[/vba]


 
Ответить
СообщениеЗдравствуйте.
Чем ВПР провинилась?[vba]
Код
Sub AutoShape20_Щелчок()
    Dim rng As Range
    Set C_is = CreateObject("scripting.dictionary")
    With ThisWorkbook.Worksheets("данные")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        Set rng = .Range("B1:F" & LastRow)
        For i = 1 To rng.Rows.Count
            Key = rng(i, 1).Offset(0, -1) & ""
            If Key <> "" Then
                Set C_is.Item(Key) = rng.Rows(i)
            End If
        Next
    End With
    With ThisWorkbook.Worksheets("реестр")
        LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        dx = .Range("a1:a" & LastRow)
        .Range("g6:k" & LastRow).ClearContents
        For i = 6 To UBound(dx)
            Key = dx(i, 1) & ""
            If Key <> "" Then
                If C_is.Exists(Key) Then
                    C_is.Item(Key).Copy .Range("g" & i)
                End If
            End If
        Next
    End With
End Sub
[/vba]

Автор - doober
Дата добавления - 16.11.2018 в 21:32
parovoznik Дата: Пятница, 16.11.2018, 22:07 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 262
Репутация: 15 ±
Замечаний: 0% ±

Excel 2007
doober, ВПР ни чем не провинилась. Я незнал ,как прописать макрос. Если не трудно можно комментарий к коду.
Дякую Вам. hands
 
Ответить
Сообщениеdoober, ВПР ни чем не провинилась. Я незнал ,как прописать макрос. Если не трудно можно комментарий к коду.
Дякую Вам. hands

Автор - parovoznik
Дата добавления - 16.11.2018 в 22:07
doober Дата: Пятница, 16.11.2018, 22:57 | Сообщение № 4
Группа: Друзья
Ранг: Ветеран
Сообщений: 512
Репутация: 231 ±
Замечаний: 0% ±

Excel 2007
Кратко могу.
В словарь заносим строки с листа данные для копирования по ключу Номер вагона.
На листе реестр очищаем диапазон для вывода результата.
Перебираем номера вагонов, если есть в словаре, то копируем строку на лист в нужный номер строки.


 
Ответить
СообщениеКратко могу.
В словарь заносим строки с листа данные для копирования по ключу Номер вагона.
На листе реестр очищаем диапазон для вывода результата.
Перебираем номера вагонов, если есть в словаре, то копируем строку на лист в нужный номер строки.

Автор - doober
Дата добавления - 16.11.2018 в 22:57
ABC Дата: Суббота, 17.11.2018, 07:42 | Сообщение № 5
Группа: Друзья
Ранг: Обитатель
Сообщений: 393
Репутация: 110 ±
Замечаний: 0% ±

Excel 2007
Вариант
[vba]
Код
Sub Test()
    Dim i&, y&, a(), b(), c()
    With Sheets("данные")
        a = .Range("A5:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    With Sheets("реестр")
        b = .Range("A6:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    ReDim c(1 To UBound(b), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            .Item(a(i, 1)) = i
        Next
        
        For i = 1 To UBound(b)
            If .Exists(b(i, 1)) Then
                For y = 1 To 5
                    c(i, y) = a(.Item(b(i, 1)), y + 1)
                Next
            End If
        Next
    End With
    With Sheets("реестр")
        .Range("G6:K" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        .[g6].Resize(i - 1, 5).Value = c
    End With
End Sub
[/vba]


MS Excel 2007 and 2010...
-------------------------------
С Уважением, Даулет
 
Ответить
СообщениеВариант
[vba]
Код
Sub Test()
    Dim i&, y&, a(), b(), c()
    With Sheets("данные")
        a = .Range("A5:F" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    With Sheets("реестр")
        b = .Range("A6:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value
    End With
    ReDim c(1 To UBound(b), 1 To 5)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(a)
            .Item(a(i, 1)) = i
        Next
        
        For i = 1 To UBound(b)
            If .Exists(b(i, 1)) Then
                For y = 1 To 5
                    c(i, y) = a(.Item(b(i, 1)), y + 1)
                Next
            End If
        Next
    End With
    With Sheets("реестр")
        .Range("G6:K" & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        .[g6].Resize(i - 1, 5).Value = c
    End With
End Sub
[/vba]

Автор - ABC
Дата добавления - 17.11.2018 в 07:42
parovoznik Дата: Воскресенье, 18.11.2018, 10:40 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 262
Репутация: 15 ±
Замечаний: 0% ±

Excel 2007
doober,благодарю за комментарии к коду. hands
АВС, спасибо за помощь hands
 
Ответить
Сообщениеdoober,благодарю за комментарии к коду. hands
АВС, спасибо за помощь hands

Автор - parovoznik
Дата добавления - 18.11.2018 в 10:40
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Сравнение ячеек на 2-х листах и копирование при совпадении. (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс цитирования
© 2010-2018 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!