Цикл сравнения ячеек со значениями массива vba

Я пытаюсь написать цикл, сравнивающий все значения из столбца A со всеми значениями из MyArray. Если значение ячейки совпадает с некоторым значением из массива, я хотел бы скопировать эту ячейку на другой соответствующий лист (все листы названы как элементы в массиве).

Sub sheets()

    Dim MyArray As Variant
    Dim element As Variant
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim ws As Worksheet
    Set ws = wb.Worksheets(1)
    Dim ws2 As Worksheet
    Set ws2 = wb.Worksheets("Sheet2")
    Dim i As Integer

    FinalRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

With ws

'Part that creates my Array without duplicates


.Range("A2", .Range("A2").End(xlDown)).RemoveDuplicates Columns:=Array(1)
MyArray = .Range("A2", .Range("A2").End(xlDown))

End With

'I copy column A from another sheet in order to restore values erased with .removeduplicates
'I've tried to remove duplicates from the Array itself but I kept getting errors so I've decided to go with this workaround
ws2.Range("A2", ws2.Range("A2").End(xlDown)).Copy Destination:=ws.Cells(2, 1)


For Each element In MyArray
    ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = element
Next element

' Below part works well but only for the number of rows equal to number of elements in the array ~15

For i = 2 To FinalRow
    For Each element In MyArray

        If element = ws.Cells(i, 1).Value Then

        ws.Cells(i, 1).Copy Destination:=wb.Worksheets(element).Cells(i, 1)

        End If

  Next element

Next i

ws.Activate

End Sub

Кажется, все работает нормально, но только для количества строк, равного количеству элементов в массиве. Я думаю, что что-то не так с логикой цикла, но я не могу понять, что именно.

2
0
2 066
3
Перейти к ответу Данный вопрос помечен как решенный

Ответы 3

Ответ принят как подходящий

Может быть, это? Ваш цикл переходит в FinalRow, но впоследствии вы изменяете значения в столбце A, поэтому предположительно он устарел. Вы можете использовать Match, чтобы избежать внутреннего цикла.

Sub sheets()

Dim MyArray As Variant
Dim element As Variant
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets("Sheet2")
Dim i As Long
Dim r As Range
Dim v As Variant

With ws
    .Range("A2", .Range("A2").End(xlDown)).RemoveDuplicates Columns:=Array(1)
    MyArray = .Range("A2", .Range("A2").End(xlDown))
End With

ws2.Range("A2", ws2.Range("A2").End(xlDown)).Copy Destination:=ws.Cells(2, 1)

For Each element In MyArray
    wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = element
Next element

For Each r In ws.Range("A2", ws.Range("A2").End(xlDown))
    v = Application.Match(r, MyArray, 0)
    If IsNumeric(v) Then
        r.Copy Destination:=wb.Worksheets(CStr(MyArray(v,1))).Cells(r.Row, 1)
    End If
Next r

ws.Activate

End Sub

Я бы использовал объект Dictionary

Sub sheetss()
    Dim cell As Range
    Dim dict1 As Object, dict2 As Object

    With ThisWorkbook ' reference wanted workbook
        Set dict1 = CreateObject("Scripting.Dictionary")
        With .Worksheets(1) ' reference referenced workbook relevant worksheet
            For Each cell In .Range("A2", .Range("A2").End(xlDown)) ' loop through referenced worksheet column A cells from row 2 down to last not empty one
                dict1(cell.Value) = 1 'store unique values from looped cells into dictionary keys
            Next
        End With

        Set dict2 = CreateObject("Scripting.Dictionary")
        With .Worksheets("Sheet2") ' reference referenced workbook relevant worksheet
            For Each cell In .Range("A2", .Range("A2").End(xlDown)) ' loop through referenced worksheet column A cells from row 2 down to last not empty one
                dict2(cell.Value) = dict1.exists(cell.Value) 'store unique values from looped cells into dictionary keys and its presence in first worksheet column A cells into corresponding item
            Next
        End With

        Dim key As Variant
        For Each key In dict2.keys ' loop through 2nd worksheet column A unique values
            If dict2(key) Then ' if it was in 1st worksheet column A cells also
                .sheets.Add(After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count)).Name = key ' create corresponding worksheet
                .sheets(key).Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = key ' copy its value into cell B1 of newly created worksheet
            End If
        Next
    End With
End Sub

Спасибо. У меня нет опыта работы со словарями, но ваши комментарии действительно помогают мне понять, как они работают.

Tomek 11.04.2018 15:05

Дайте мне знать, каким будет ваш окончательный выбор

DisplayName 11.04.2018 18:33

Также со словарем

Option Explicit

Public Sub WriteToSheets()
    Application.ScreenUpdating = False
    Dim MyArray As Variant, wb As Workbook, ws As Worksheet, ws2 As Worksheet, i As Long, dict As Object, rng As Range
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets(1)
    Set ws2 = wb.Worksheets("Sheet2")
    Set dict = CreateObject("Scripting.Dictionary")

    With ws
        MyArray = Intersect(.Columns(1), .UsedRange)
        For i = LBound(MyArray, 1) To UBound(MyArray, 1)
            If Not dict.exists(MyArray(i, 1)) Then
                dict.Add MyArray(i, 1), 1
                On Error Resume Next 'in case already exists
                wb.sheets.Add(After:=wb.sheets(wb.sheets.Count)).Name = MyArray(i, 1)
                On Error GoTo 0
            End If
        Next i
    End With
    With ws2
        For Each rng In Intersect(.Columns(1), .UsedRange)
            If dict.exists(rng.Value) Then
                rng.Copy wb.Worksheets(rng.Value).Range("A" & GetNextRow(wb.Worksheets(rng.Value), 1))
            End If
        Next rng
    End With
    Application.ScreenUpdating = True
End Sub

Public Function GetNextRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
    With ws
        GetNextRow = IIf(.Cells(.Rows.Count, columnNumber).End(xlUp).Row = 1, 1, .Cells(.Rows.Count, columnNumber).End(xlUp).Row + 1)
    End With
End Function

Спасибо. Мне нужно проанализировать этот код, так как у меня нет опыта работы со словарями, но я обязательно им воспользуюсь в будущем

Tomek 11.04.2018 15:03

Другие вопросы по теме