Как добавить соответствующее значение в правом столбце (у меня есть код, но это не достаточно быстро) - PullRequest
Новая
       20

Как добавить соответствующее значение в правом столбце (у меня есть код, но это не достаточно быстро)

1 голос
/ 07 ноября 2019

У меня проблема с моим VBA-кодом. Я очень ОЧЕНЬ новичок в VBA и кодировании, так что помощь действительно нужна, СПАСИБО! :)

Я использую 'test excel', чтобы проверить мой макрос, и вот дело. В моем тесте Excel у меня есть столбцы от A до F. Я должен добавить значение к столбцу F, если столбец A имеет то же значение, что и столбец G. Также мне нужно удалить все возможные дубликаты из диапазона от A до C. Вот пример: 

 A  B  C  D  E  F      G  H
 1  2  2  2  2         1  work
 2  3  3  3  3         2  school
 2  3  3  3  3
 4  1  1  1  1

 After macro ----->

   One
A  B  C  D  E  F         G  H
1  2  2  2  2  work      1  work
2  3  3  3  3  school    2  school
4  1  1  1  1

Итак, теперь список обновлен значениями в столбце F и удалена третья строка (потому чтоэто был дубликат).

Это то, что я уже пробовал. Я не знаю, как сделать этот макрос проверяет столбец G и добавляет значение столбца H в столбец F, если значения совпадают. Вот что я сделал: 

Private Sub CommandButton1_Click()

ActiveSheet.Range("A1:E100").RemoveDuplicates Columns:=Array(1, 2, 3),     Header:=xlYes

For Each ordernmb In Range("A1:A100")
    If ordernmb = "1" Then
        ordernmb.Offset(0, 5).Value = "work"

    ElseIf ordernmb = "2" Then
        ordernmb.Offset(0, 5).Value = "school"

    End If

    Next ordernmb

End Sub

В настоящем Excel у меня более 10 000 строк, 15 столбцов, так что этот код был слишком медленным для этого ... что мне делать? Спасибо за ваше терпение :)

1 Ответ

2 голосов
/ 07 ноября 2019

Согласно моим комментариям, вы можете ускорить свой процесс, обходя память вместо Range объектов (доступ к ячейкам один за другим медленный).

То есть с этим конкретным примером данных, который выглядит следующим образом:

enter image description here

Пример кода может выглядеть следующим образом: 

Sub Test()

Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim lr As Long, x As Long
Dim arr As Variant

With Sheet1 'Change according to your sheets CodeName

    'Populate dictionary from column G:H
    lr = .Cells(.Rows.Count, 7).End(xlUp).Row
    arr = .Range("G1:H" & lr)
    For x = LBound(arr) To UBound(arr)
        dict.Add arr(x, 1), arr(x, 2)
    Next x

    'Delete duplicates in columns A:E
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1:E" & lr).RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlNo

    'Go through remaining values to get values for column F
    lr = .Cells(.Rows.Count, 1).End(xlUp).Row
    arr = .Range("A1:F" & lr)
    For x = LBound(arr) To UBound(arr)
        arr(x, 6) = dict(arr(x, 1))
    Next x

    'Populate column F
    .Range("A1:F" & lr) = arr

End With

End Sub

Результат:

enter image description here

...