При сверке ячеек некоректно выдает результаты

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

При сверке ячеек некоректно выдает результаты (Макросы/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 столбца для каждого обозначения но на протяжении всех столбцов. (красным и зеленым показал участки как делает и как должен был разбить)
Заранее спасибо за помощь.

[vba]

Код

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

[/vba]

Код

[/vba]Ant645

К сообщению приложен файл: 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]

Код

[/vba]

Автор - Ant645
Дата добавления - 09.03.2020 в 06:41

Kuzmich

Дата: Среда, 11.03.2020, 15:10 | Сообщение № 2

Группа: Проверенные

Ранг: Ветеран

Сообщений: 713

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

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

Код

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]

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

Код

[/vba]Kuzmich

Ответить

СообщениеКак вы хотите пока не получается, но можно сделать в сокращенном виде. Может так устроит?
[vba]

Код

[/vba]

Автор - Kuzmich
Дата добавления - 11.03.2020 в 15:10

При сверке ячеек некоректно выдает результаты (Макросы/Sub)

Страница 1 из 1
1