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

 

= Мир MS Excel/При сверке ячеек некоректно выдает результаты - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » При сверке ячеек некоректно выдает результаты (Макросы/Sub)
При сверке ячеек некоректно выдает результаты
Ant645 Дата: Понедельник, 09.03.2020, 06:41 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Здравствуйте!
Есть макрос который сравнивает столбцы и выдает результаты в таблицу. Макрос берет значения со столбца "Q" сравнивает с "K" (заполняет столбец "R" и "S", в "R" заполняет по сравнению Q и К, а в S то куда входит (значение со столбца M)). Если в Q и K несколько значений с разной входимостью он отдельно заносит данные для каждого. Потом макрос берет значение которое заносилось в столбец S и находит его в столбце А и заносит куда входит (сравнивает значение F и M и в столбец T копирует значение из H) и так далее. Возникла проблема, что макрос дальше не разбивает на отдельные строки значения, а копирует по несколько штук в один) При этом когда сравнивает следующий уровень он берет только первое значение (например Т4 и Т5, он показал куда входит эти значения только для Т4). Файл прилагаю, вариант как должно быть указат под синим заголовком. Необходимо что бы он разбивал как первые 2 столбца для каждого обозначения но на протяжении всех столбцов. (красным и зеленым показал участки как делает и как должен был разбить)
Заранее спасибо за помощь.



Sub Ïðîáíèê_6()
Dim lLastRowK As Long
Dim lLastRowL As Long
Dim lLastRowM As Long
Dim rFind_F As Range
Dim rFind_A As Range
Dim rFind_C As Range
Dim i As Long
Dim FAdr_F As String
Dim FAdr_A As String
Dim FAdr_C As String

    'âûäàåò ðåçóëüòàò ñêîëüêî 2 è 3 åñòü â ñòîëáöå K, ðåçóëüòàò â R
lLastRowK = Cells(Rows.Count, "Q").End(xlUp).Row
lLastRowL = 2
    Range("R2:U1000").ClearContents

    
    
For i = 2 To lLastRowK   'öèêë ïî çíà÷åíèÿì ñòîëáöà Q
    'èùåì â ñòîëáöå K çíà÷åíèÿ ñòîëáöà Q
    Set rFind_F = Columns("K").Find(Cells(i, "Q"), , xlValues, xlWhole)
    If Not rFind_F Is Nothing Then 'íàøëè ïåðâîå âõîæäåíèå
    FAdr_F = rFind_F.Address       'àäðåñ ïåðâîãî âõîæäåíèÿ
    Do
        Cells(lLastRowL, "R") = rFind_F
        lLastRowL = lLastRowL + 1
        Cells(lLastRowL, "S") = rFind_F.Offset(, 2)
        lLastRowL = lLastRowL + 1
        'èùåì â ñòîëáöå K (îáîçíà÷åíèå 2) çíà÷åíèå èç ñòîëáöà N (êóäà âõîäèò 1)
        Set rFind_A = Columns("F").Find(rFind_F.Offset(, 2), , xlValues, xlWhole)
        If Not rFind_A Is Nothing Then 'íàøëè ïåðâîå âõîæäåíèå
            FAdr_A = rFind_A.Address       'àäðåñ ïåðâîãî âõîæäåíèÿ
            Do
        
            Cells(lLastRowL, "T") = rFind_A.Offset(, 2)
            
            
            
            Set rFind_A = Columns("F").FindNext(rFind_A)
            lLastRowL = lLastRowL + 1
            Loop While rFind_A.Address <> FAdr_A
            
            
            
        Set rFind_C = Columns("A").Find(rFind_A.Offset(, 2), , xlValues, xlWhole)
        If Not rFind_C Is Nothing Then
            FAdr_C = rFind_C.Address
            Do
        
            Cells(lLastRowL, "U") = rFind_C.Offset(, 2)
            
            
            
            Set rFind_C = Columns("A").FindNext(rFind_C)
        
            lLastRowL = lLastRowL + 1
            Loop While rFind_C.Address <> FAdr_C
        
        
            End If
        End If
        
        Set rFind_F = Columns("K").Find(Cells(i, "Q"), After:=rFind_F)
        lLastRowL = lLastRowL + 1
    Loop While rFind_F.Address <> FAdr_F
    End If
lLastRowL = Cells(Rows.Count, "U").End(xlUp).Row + 2
Next
End Sub

К сообщению приложен файл: 4676993.xlsm (19.0 Kb)


Сообщение отредактировал Ant645 - Понедельник, 09.03.2020, 06:51
 
Ответить
СообщениеЗдравствуйте!
Есть макрос который сравнивает столбцы и выдает результаты в таблицу. Макрос берет значения со столбца "Q" сравнивает с "K" (заполняет столбец "R" и "S", в "R" заполняет по сравнению Q и К, а в S то куда входит (значение со столбца M)). Если в Q и K несколько значений с разной входимостью он отдельно заносит данные для каждого. Потом макрос берет значение которое заносилось в столбец S и находит его в столбце А и заносит куда входит (сравнивает значение F и M и в столбец T копирует значение из H) и так далее. Возникла проблема, что макрос дальше не разбивает на отдельные строки значения, а копирует по несколько штук в один) При этом когда сравнивает следующий уровень он берет только первое значение (например Т4 и Т5, он показал куда входит эти значения только для Т4). Файл прилагаю, вариант как должно быть указат под синим заголовком. Необходимо что бы он разбивал как первые 2 столбца для каждого обозначения но на протяжении всех столбцов. (красным и зеленым показал участки как делает и как должен был разбить)
Заранее спасибо за помощь.

[vba]
Sub Ïðîáíèê_6()Dim lLastRowK As LongDim lLastRowL As LongDim lLastRowM As LongDim rFind_F As RangeDim rFind_A As RangeDim rFind_C As RangeDim i As LongDim FAdr_F As StringDim FAdr_A As StringDim FAdr_C As String    'âûäàåò ðåçóëüòàò ñêîëüêî 2 è 3 åñòü â ñòîëáöå K; ðåçóëüòàò â RlLastRowK = Cells(Rows.Count; "Q").End(xlUp).RowlLastRowL = 2    Range("R2:U1000").ClearContents        For i = 2 To lLastRowK   'öèêë ïî çíà÷åíèÿì ñòîëáöà Q    'èùåì â ñòîëáöå K çíà÷åíèÿ ñòîëáöà Q    Set rFind_F = Columns("K").Find(Cells(i; "Q"); ; xlValues; xlWhole)    If Not rFind_F Is Nothing Then 'íàøëè ïåðâîå âõîæäåíèå    FAdr_F = rFind_F.Address       'àäðåñ ïåðâîãî âõîæäåíèÿ    Do        Cells(lLastRowL; "R") = rFind_F        lLastRowL = lLastRowL + 1        Cells(lLastRowL; "S") = rFind_F.Offset(; 2)        lLastRowL = lLastRowL + 1        'èùåì â ñòîëáöå K (îáîçíà÷åíèå 2) çíà÷åíèå èç ñòîëáöà N (êóäà âõîäèò 1)        Set rFind_A = Columns("F").Find(rFind_F.Offset(; 2); ; xlValues; xlWhole)        If Not rFind_A Is Nothing Then 'íàøëè ïåðâîå âõîæäåíèå            FAdr_A = rFind_A.Address       'àäðåñ ïåðâîãî âõîæäåíèÿ            Do                     Cells(lLastRowL; "Т") = rFind_A.Offset(; 2)                                                   Set rFind_A = Columns("F").FindЧext(rFind_A)            lLastRowL = lLastRowL + 1            Loop While rFind_A.Address <> FAdr_A                                            Set rFind_C = Columns("A").Find(rFind_A.Offset(; 2); ; xlValues; xlWhole)        If Not rFind_C Is Nothing Then            FAdr_C = rFind_C.Address            Do                     Cells(lLastRowL; "U") = rFind_C.Offset(; 2)                                                  Set rFind_C = Columns("A").FindЧext(rFind_C)                     lLastRowL = lLastRowL + 1            Loop While rFind_C.Address <> FAdr_C                               End If         End If                Set rFind_F = Columns("K").Find(Cells(i; "Q"); After:=rFind_F)        lLastRowL = lLastRowL + 1    Loop While rFind_F.Address <> FAdr_F    End IflLastRowL = Cells(Rows.Count; "U").End(xlUp).Row + 2NextEnd Sub
[/vba]
Автор - Ant645
Дата добавления - 09.03.2020 в 06:41
Kuzmich Дата: Среда, 11.03.2020, 15:10 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 715
Репутация: 157 ±
Замечаний: 0% ±

Excel 2003
Как вы хотите пока не получается, но можно сделать в сокращенном виде. Может так устроит?

Option Explicit
Sub Пробник_6()
Dim lLastRowQ As Long
Dim lLastRowR_U As Long
Dim rFind_K As Range
Dim rFind_F As Range
Dim rFind_A As Range
Dim i As Long
Dim FAdr_K As String
Dim FAdr_F As String
Dim FAdr_A As String
lLastRowQ = Cells(Rows.Count, "Q").End(xlUp).Row
    Range("R2:U1000").ClearContents
    lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
For i = 2 To lLastRowQ   'цикл по значениям столбца Q
    'ищем в столбце K значения столбца Q
    Set rFind_K = Columns("K").Find(Cells(i, "Q"), , xlValues, xlWhole)
    If Not rFind_K Is Nothing Then 'нашли первое вхождение
    FAdr_K = rFind_K.Address       'адрес первого вхождения
    Do
        Cells(lLastRowR_U, "R") = rFind_K
        lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
        Cells(lLastRowR_U, "S") = rFind_K.Offset(, 2) 'из столбца М
        lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
        'ищем в столбце F (обозначение 2) значение из столбца M (куда входит 1)
        Set rFind_F = Columns("F").Find(rFind_K.Offset(, 2), , xlValues, xlWhole)
        If Not rFind_F Is Nothing Then     'нашли первое вхождение
            FAdr_F = rFind_F.Address       'адрес первого вхождения
            Do
            Cells(lLastRowR_U, "T") = rFind_F.Offset(, 2)
            lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            Set rFind_A = Columns("A").Find(rFind_F.Offset(, 2), , xlValues, xlWhole)
            If Not rFind_A Is Nothing Then
                FAdr_A = rFind_A.Address
                Do
                Cells(lLastRowR_U, "U") = rFind_A.Offset(, 2)
                lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
                Set rFind_A = Columns("A").Find(rFind_F.Offset(, 2), rFind_A, xlValues, xlWhole)
                lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
                Loop While rFind_A.Address <> FAdr_A
        End If
            Set rFind_F = Columns("F").Find(rFind_K.Offset(, 2), rFind_F, xlValues, xlWhole)
            lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
            Loop While rFind_F.Address <> FAdr_F
        End If
        Set rFind_K = Columns("K").Find(Cells(i, "Q"), After:=rFind_K)
        lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
    Loop While rFind_K.Address <> FAdr_K
    End If
lLastRowR_U = Range("R:U").Find("*", Range("R1"), xlValues, xlWhole, xlByRows, xlPrevious).Row + 2
Next
End Sub

 
Ответить
СообщениеКак вы хотите пока не получается, но можно сделать в сокращенном виде. Может так устроит?
[vba]
Option ExplicitSub Пробник_6()Dim lLastRowQ As LongDim lLastRowR_U As LongDim rFind_K As RangeDim rFind_F As RangeDim rFind_A As RangeDim i As LongDim FAdr_K As StringDim FAdr_F As StringDim FAdr_A As String   lLastRowQ = Cells(Rows.Count; "Q").End(xlUp).Row    Range("R2:U1000").ClearContents    lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1For i = 2 To lLastRowQ   'цикл по значениям столбца Q    'ищем в столбце K значения столбца Q    Set rFind_K = Columns("K").Find(Cells(i; "Q"); ; xlValues; xlWhole)    If Not rFind_K Is Nothing Then 'нашли первое вхождение      FAdr_K = rFind_K.Address       'адрес первого вхождения      Do        Cells(lLastRowR_U; "R") = rFind_K        lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1        Cells(lLastRowR_U; "S") = rFind_K.Offset(; 2) 'из столбца М        lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1        'ищем в столбце F (обозначение 2) значение из столбца M (куда входит 1)        Set rFind_F = Columns("F").Find(rFind_K.Offset(; 2); ; xlValues; xlWhole)        If Not rFind_F Is Nothing Then     'нашли первое вхождение            FAdr_F = rFind_F.Address       'адрес первого вхождения            Do              Cells(lLastRowR_U; "Т") = rFind_F.Offset(; 2)              lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1               Set rFind_A = Columns("A").Find(rFind_F.Offset(; 2); ; xlValues; xlWhole)               If Not rFind_A Is Nothing Then                 FAdr_A = rFind_A.Address                 Do                   Cells(lLastRowR_U; "U") = rFind_A.Offset(; 2)                  lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1                  Set rFind_A = Columns("A").Find(rFind_F.Offset(; 2); rFind_A; xlValues; xlWhole)                  lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1                 Loop While rFind_A.Address <> FAdr_A          End If              Set rFind_F = Columns("F").Find(rFind_K.Offset(; 2); rFind_F; xlValues; xlWhole)              lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1            Loop While rFind_F.Address <> FAdr_F         End If        Set rFind_K = Columns("K").Find(Cells(i; "Q"); After:=rFind_K)        lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 1      Loop While rFind_K.Address <> FAdr_K    End If  lLastRowR_U = Range("R:U").Find("*"; Range("R1"); xlValues; xlWhole; xlByRows; xlPrevious).Row + 2NextEnd Sub
[/vba]
Автор - Kuzmich
Дата добавления - 11.03.2020 в 15:10
Мир MS Excel » Вопросы и решения » Вопросы по VBA » При сверке ячеек некоректно выдает результаты (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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