Используйте массив и возвращайте значения по одному - PullRequest
Новая
       1

Используйте массив и возвращайте значения по одному

4 голосов
/ 20 сентября 2019

Я хочу запустить код, который назначил несколько массивов в 2 рабочих листах и ​​на основе сопоставления возвращает данные с одного листа на другой.

На листе 1:

Здесь у меня есть 3 столбца данных (например, строк не так много, но их будет много): enter image description here

Влист 2 У меня есть следующие данные: enter image description here

Поэтому я хочу сопоставить столбец C на листе 2 со столбцом A на листе 1, то есть сопоставитьна основе идентификаторов.Основываясь на этом совпадении, и если на листе 2 в столбце E есть текст «Да», то из столбца А листа 1 и столбца В я хочу записать значения в лист 2 соответственно в столбцах F и GIe «Имя» и «Число».'.

Следовательно, это мой желаемый результат для достижения на листе 2 после выполнения кода: enter image description here

Я хотел назначить столбцы данных из листа 1 для массивов.и то же самое для столбца с идентификаторами в sheet2.У меня будет намного больше данных!

Проблема с моим кодом состоит в том, что вместо извлечения значений из sheet1 один за другим на основе совпадения с iID в sheet2, он фактически возвращает только первые значения для «Имени» и«Number» из sheet1 для такого же «Yes», ​​как и для sheet2 (оно удваивает возвращаемые значения) вместо того, чтобы возвращать одно за другим.

Это мой код: 

Sub test()

Dim w_result As Worksheet
Dim w1 As Worksheet

Dim r As Long
Dim d As Long
Dim intLastRow As Long
Dim IntLastRow_Result As Long
Dim IntLastCol As Long

Dim arrID() As Variant
Dim arrName() As Variant
Dim arrNumber() As Variant


With ThisWorkbook
    Set w1 = .Sheets("Sheet1")
    Set w_result= .Sheets("Sheet2")
End With


With w1
    intLastRow = .Cells(.Rows.Count, 1).End(xlUp).row
    IntLastRow_Result = w_result.Cells(Rows.Count, 3).End(xlUp).row

    arrID = .Range(.Cells(5, 3), .Cells(intLastRow, 3))
    arrName= .Range(.Cells(5, 1), .Cells(intLastRow, 1))
    arrNumber= .Range(.Cells(5, 2), .Cells(intLastRow, 2))


   For r = 1 To UBound(arrID , 1)
        If Len(arrID (r, 1)) > 0 Then
            For d = 4 To IntLastRow_Result
                If w_result.Cells(d, 3) = arrID (r, 1) Then
                    If w_result.Cells(d, 5) = "Yes" Then
                        w_result.Cells(d, 6) = arrName(r, 1)
                        w_result.Cells(d, 7) = arrNumber(r, 1)
                    End If
                End If
            Next
        End If
    Next r

End With

End Sub

Я буду очень признателен за любую помощь в этом!

Ответы [ 3 ]

2 голосов
/ 23 сентября 2019

Ваша ошибка в том, что каждый раз, когда найдено совпадение, цикл For d = ... перезаписывает предыдущие результаты.

Быстрое и грязное исправление состоит в том, чтобы проверить строку результата на пустое, если найденопустой результат записи, затем выйдите из внутреннего цикла for. 

Sub test()
    Dim w_result As Worksheet
    Dim w1 As Worksheet

    Dim r As Long
    Dim d As Long
    Dim intLastRow As Long
    Dim IntLastRow_Result As Long
    Dim IntLastCol As Long

    Dim arrID() As Variant
    Dim arrName() As Variant
    Dim arrNumber() As Variant

    Dim ResultRow As Long

    With ThisWorkbook
        Set w1 = .Sheets("Sheet1")
        Set w_result = .Sheets("Sheet2")
    End With

    With w1
        intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        IntLastRow_Result = w_result.Cells(w_result.Rows.Count, 3).End(xlUp).Row '<~~ removed implicit active sheet reference

        arrID = .Range(.Cells(5, 3), .Cells(intLastRow, 3))
        arrName = .Range(.Cells(5, 1), .Cells(intLastRow, 1))
        arrNumber = .Range(.Cells(5, 2), .Cells(intLastRow, 2))

        For r = 1 To UBound(arrID, 1)
            If Len(arrID(r, 1)) > 0 Then
                For d = 4 To IntLastRow_Result
                    If w_result.Cells(d, 3) = arrID(r, 1) Then
                        If w_result.Cells(d, 5) = "Yes" Then
                            If IsEmpty(w_result.Cells(d, 6)) Then '<~~~ Added
                                w_result.Cells(d, 6) = arrName(r, 1)
                                w_result.Cells(d, 7) = arrNumber(r, 1)
                                Exit For  '<~~~ Added
                            End If
                        End If
                    End If
                Next
            End If
        Next r
    End With
End Sub

Примечание: это очень неэффективное решение, но оно подойдет для небольших наборов данных.

Вот более эффективная версия, использующая Variant Array для результатов и обновляющая начальный индекс внутреннего цикла 

Sub test()
    Dim w_result As Worksheet
    Dim w1 As Worksheet

    Dim r As Long
    Dim d As Long
    Dim intLastRow As Long
    Dim IntLastRow_Result As Long
    Dim IntLastCol As Long

    Dim arrID() As Variant
    Dim arrName() As Variant
    Dim arrNumber() As Variant
    Dim Results() As Variant
    Dim ResultStart As Long
    Dim ResultRow As Long

    With ThisWorkbook
        Set w1 = .Sheets("Sheet1")
        Set w_result = .Sheets("Sheet2")
    End With

    With w1
        intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        IntLastRow_Result = w_result.Cells(w_result.Rows.Count, 3).End(xlUp).Row '<~~ removed implicit active sheet reference
        Results = w_result.Cells(1, 1).Resize(IntLastRow_Result, 8).Value
        w_result.Activate
        arrID = .Range(.Cells(5, 3), .Cells(intLastRow, 3))
        arrName = .Range(.Cells(5, 1), .Cells(intLastRow, 1))
        arrNumber = .Range(.Cells(5, 2), .Cells(intLastRow, 2))

        ResultStart = 4
        For r = 1 To UBound(arrID, 1)
            If Len(arrID(r, 1)) > 0 Then
                For d = ResultStart To IntLastRow_Result
                    If Results(d, 3) = arrID(r, 1) Then
                        If Results(d, 5) = "Yes" Then
                            If IsEmpty(Results(d, 6)) Then '<~~~ Added
                                Results(d, 6) = arrName(r, 1)
                                Results(d, 7) = arrNumber(r, 1)
                                Exit For  '<~~~ Added
                            End If
                        End If
                        ResultStart = ResultStart + 1
                    End If
                Next
            End If
        Next r
    End With
    w_result.Cells(1, 1).Resize(IntLastRow_Result, 8).Value = Results
End Sub
0 голосов
/ 24 сентября 2019

Этот пример с допущением, что содержимое sheet2 и sheet1 аналогично примеру s / o, а содержимое sheet1 отсортировано по id: 

Sub test()

    Dim w_result As Worksheet
    Dim w1 As Worksheet

    Dim r As Long
    Dim d As Long
    Dim intLastRow As Long
    Dim IntLastRow_Result As Long
    Dim IntLastCol As Long

    With ThisWorkbook
        Set w1 = .Sheets("Sheet1")
        Set w_result = .Sheets("Sheet2")
    End With


    With w1
        intLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        IntLastRow_Result = w_result.Cells(Rows.Count, 3).End(xlUp).Row

        arrNumber = .Range(.Cells(5, 1), .Cells(intLastRow, 3))

        Dim LastID As String
        LastID = ""
        lastrow = 0

        For r = 1 To UBound(arrNumber, 1)

            If Len(arrNumber(r, 3)) > 0 Then
                If arrNumber(r, 3) <> LastID Then
                   LastID = arrNumber(r, 3)
                   If arrNumber(r, 3) = "id1" Then lastrow = 4
                   If arrNumber(r, 3) = "id2" Then lastrow = 29
                   Else
                       lastrow = lastrow + 1
                End If

                If w_result.Range("E" & lastrow) = "Yes" Then
                   w_result.Range("F" & lastrow) = arrNumber(r, 1)
                   w_result.Range("G" & lastrow) = arrNumber(r, 2)
                End If

            End If
         Next r

    End With


End Sub
0 голосов
/ 23 сентября 2019

Способ, которым я решил бы, заключается в следующем.Во-первых, если вы работаете с большим набором данных в Excel, вы не хотите циклически проходить через диапазон внешнего интерфейса, а, скорее, проходите через массивы (память).

Теперь, как нам эффективно использовать массивы?Ну что нам нужно?Нам нужен массив для данных Sheet1, нам нужен и массив для выходных данных Sheet2.Сохраните данные листа sheet1 в массив И сохраните данные листа template2 в массив для целей отображения.

Примеры данных:

enter image description here

enter image description here

См. Код ниже.Вы заметите, что этот подход значительно ускорит ваше время!

Option Explicit

Sub TransferUsingArrays()

    Dim wsS1 As Worksheet, wsS2 As Worksheet
    Dim aSheet1() As Variant, aSheet2() As Variant
    Dim lRowS1 As Long, lRowS2 As Long
    Dim i As Long, j As Long


    'set the worksheets - use workbook qualifier!
    Set wsS1 = ThisWorkbook.Sheets("Sheet1")
    Set wsS2 = ThisWorkbook.Sheets("Sheet2")


    lRowS1 = wsS1.Range("A" & wsS1.Rows.Count).End(xlUp).Row
    lRowS2 = wsS2.Range("C" & wsS2.Rows.Count).End(xlUp).Row


    'set the arrays
    aSheet1 = wsS1.Range("A4").Resize(lRowS1, 3)
    aSheet2 = wsS2.Range("C3").Resize(lRowS2, 5)


    'now loop through the data array and match with sheet2 array entry
    For i = 2 To lRowS1
        'if there is a name, only look for match
        If Len(aSheet1(i, 1)) > 0 Then
            'now loop through second array to insert latest value
            For j = 2 To lRowS2
                'if the id is a match
                If aSheet2(j, 1) = aSheet1(i, 3) Then
                    'if there is a blank in name and there is yes in value
                    If aSheet2(j, 5) = "" And aSheet2(j, 3) = "Yes" Then
                        'now insert the values into second array
                        aSheet2(j, 4) = aSheet1(i, 2)
                        aSheet2(j, 5) = aSheet1(i, 1)
                        'now exit
                        Exit For
                    End If
                End If
            Next j
        End If
    Next i

    'now output the second array
    wsS2.Range("C3").Resize(lRowS2, 5) = aSheet2


End Sub

Желаемый результат:

enter image description here

Естественно корректируйте код там, где это необходимо.

Надеюсь, это то, что вы ищете ..,

Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...