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

Вход

Регистрация

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

 

= Мир MS Excel/Объединение двух кодов VBA в один - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Объединение двух кодов VBA в один
volk1729 Дата: Воскресенье, 03.04.2022, 18:33 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Здравствуйте. Есть два отличных макроса для сравнения данных - двух столбцов.
Макрос № 1 сравнивает один столбец с выделенным диапазоном и в случае совпадения пишет слово ОК (в файле примере лист № 1). Макрос № 2 тоже сравнивает столбцы между собой, но в случае совпадения располагает совпавшие данные правее таблицы т.е располагает соосно - все совпадения располагаются друг на против друга в одной строке , что очень удобно когда нужно сравнить большее количество данных, чем просто два столбца. Макрос № 1 сравнивает ячейки практически мгновенно, сотни тысяч меньше чем за 1 мин. Макрос № 2 для сравнения требует больше времени, на большом количестве ячеек значительно - 80 000 на 740 000 ячеек 3 часа 52 мин.

Макрос № 1

[vba]
Код
Sub Find_Matches()
  Dim a, b, d, r&, tm
  tm = Timer
  a = Range([m2], Cells(Rows.Count, 13).End(xlUp))
  Set d = CreateObject("Scripting.Dictionary")
  For r = 1 To UBound(a): d(a(r, 1)) = 1: Next
  a = Selection: ReDim b(1 To UBound(a), 1 To 1)
  For r = 1 To UBound(a)
    If d.exists(a(r, 1)) Then b(r, 1) = "ok"
  Next
  Selection.Offset(0, 1) = b
  MsgBox Timer - tm
End Sub
[/vba]

Макрос № 2

[vba]
Код
Sub Test()
    Dim arrNoNCD, arrData, arrOut, LastRow As Long, iRow As Long, i As Long, iCol As Long
        
    With ActiveSheet
        If .FilterMode Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        arrNoNCD = .Range("G2:G" & LastRow).Value
        LastRow = .Cells(.Rows.Count, "AD").End(xlUp).Row
        arrData = .Range("AD2:AY" & LastRow).Value
    End With
        
    ReDim arrOut(1 To UBound(arrNoNCD), 1 To UBound(arrData, 2))
    For iRow = 1 To UBound(arrNoNCD)
        For i = 1 To UBound(arrData)
            If arrData(i, 1) = arrNoNCD(iRow, 1) Then
                For iCol = 1 To UBound(arrData, 2)
                    arrOut(iRow, iCol) = arrData(i, iCol)
                Next iCol
            End If
        Next i
    Next iRow
        
    Range("BA2").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
    MsgBox "Данные выведены в столбец BA", vbInformation, "Конец"
End Sub
[/vba]

Вопрос - можно ли совместить эти макросы в одном? Например чтобы в начале столбцы сравнивались методом из макроса № 1, а дальше уже макрос № 2 правее таблицы выводил совпавшую инфу. Если это возможно то результат должен быть как при срабатывании макроса № 2 (в файле примере лист марос № 2)

Принцип работы макроса № 2. В макросе № 2 пользователь вручную указывает первый столбец для сравнения, например А, диапазон сравнения А2:А потом столбец с которым нужно сравнить В, потом те данные которые нужно скопировать через 1 столбец правее последнего заполненного столбца В2:О, и указывает столбец с которого нужно начать вставку Q2.
К сообщению приложен файл: _2_.xlsm (19.6 Kb)
 
Ответить
СообщениеЗдравствуйте. Есть два отличных макроса для сравнения данных - двух столбцов.
Макрос № 1 сравнивает один столбец с выделенным диапазоном и в случае совпадения пишет слово ОК (в файле примере лист № 1). Макрос № 2 тоже сравнивает столбцы между собой, но в случае совпадения располагает совпавшие данные правее таблицы т.е располагает соосно - все совпадения располагаются друг на против друга в одной строке , что очень удобно когда нужно сравнить большее количество данных, чем просто два столбца. Макрос № 1 сравнивает ячейки практически мгновенно, сотни тысяч меньше чем за 1 мин. Макрос № 2 для сравнения требует больше времени, на большом количестве ячеек значительно - 80 000 на 740 000 ячеек 3 часа 52 мин.

Макрос № 1

[vba]
Код
Sub Find_Matches()
  Dim a, b, d, r&, tm
  tm = Timer
  a = Range([m2], Cells(Rows.Count, 13).End(xlUp))
  Set d = CreateObject("Scripting.Dictionary")
  For r = 1 To UBound(a): d(a(r, 1)) = 1: Next
  a = Selection: ReDim b(1 To UBound(a), 1 To 1)
  For r = 1 To UBound(a)
    If d.exists(a(r, 1)) Then b(r, 1) = "ok"
  Next
  Selection.Offset(0, 1) = b
  MsgBox Timer - tm
End Sub
[/vba]

Макрос № 2

[vba]
Код
Sub Test()
    Dim arrNoNCD, arrData, arrOut, LastRow As Long, iRow As Long, i As Long, iCol As Long
        
    With ActiveSheet
        If .FilterMode Then .ShowAllData
        LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
        arrNoNCD = .Range("G2:G" & LastRow).Value
        LastRow = .Cells(.Rows.Count, "AD").End(xlUp).Row
        arrData = .Range("AD2:AY" & LastRow).Value
    End With
        
    ReDim arrOut(1 To UBound(arrNoNCD), 1 To UBound(arrData, 2))
    For iRow = 1 To UBound(arrNoNCD)
        For i = 1 To UBound(arrData)
            If arrData(i, 1) = arrNoNCD(iRow, 1) Then
                For iCol = 1 To UBound(arrData, 2)
                    arrOut(iRow, iCol) = arrData(i, iCol)
                Next iCol
            End If
        Next i
    Next iRow
        
    Range("BA2").Resize(UBound(arrOut, 1), UBound(arrOut, 2)).Value = arrOut
    MsgBox "Данные выведены в столбец BA", vbInformation, "Конец"
End Sub
[/vba]

Вопрос - можно ли совместить эти макросы в одном? Например чтобы в начале столбцы сравнивались методом из макроса № 1, а дальше уже макрос № 2 правее таблицы выводил совпавшую инфу. Если это возможно то результат должен быть как при срабатывании макроса № 2 (в файле примере лист марос № 2)

Принцип работы макроса № 2. В макросе № 2 пользователь вручную указывает первый столбец для сравнения, например А, диапазон сравнения А2:А потом столбец с которым нужно сравнить В, потом те данные которые нужно скопировать через 1 столбец правее последнего заполненного столбца В2:О, и указывает столбец с которого нужно начать вставку Q2.

Автор - volk1729
Дата добавления - 03.04.2022 в 18:33
AB0885 Дата: Воскресенье, 10.04.2022, 16:35 | Сообщение № 2
Группа: Пользователи
Ранг: Участник
Сообщений: 60
Репутация: 0 ±
Замечаний: 20% ±

volk1729, попробуйте оставить ваши макросы и добавить такой:[vba]
Код

Sub объединённый()
'
    Call Find_Matches
    Call Test
       End Sub
[/vba]
Где-то здесь подсмотрел
 
Ответить
Сообщениеvolk1729, попробуйте оставить ваши макросы и добавить такой:[vba]
Код

Sub объединённый()
'
    Call Find_Matches
    Call Test
       End Sub
[/vba]
Где-то здесь подсмотрел

Автор - AB0885
Дата добавления - 10.04.2022 в 16:35
volk1729 Дата: Воскресенье, 10.04.2022, 16:37 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

AB0885 спасибо за помощь
 
Ответить
СообщениеAB0885 спасибо за помощь

Автор - volk1729
Дата добавления - 10.04.2022 в 16:37
  • Страница 1 из 1
  • 1
Поиск:

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