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

Вход

Регистрация

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

 

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

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир 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 столбца для каждого обозначения но на протяжении всех столбцов. (красным и зеленым показал участки как делает и как должен был разбить)
Заранее спасибо за помощь.

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

Автор - Ant645
Дата добавления - 09.03.2020 в 06:41
Kuzmich Дата: Среда, 11.03.2020, 15:10 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 475
Репутация: 97 ±
Замечаний: 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]
Код
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]

Автор - Kuzmich
Дата добавления - 11.03.2020 в 15:10
Мир MS Excel » Вопросы и решения » Вопросы по VBA » При сверке ячеек некоректно выдает результаты (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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