Início / computer / Perguntas / 1703293
Accepted
wyatt7613
Asked: 2022-02-05 21:15:12 +0800 CST

Excel VBA - matriz dinâmica não está funcionando

  • 772

Estou tentando fazer uma matriz que armazena todos os valores na coluna A da "Pasta de trabalho B" para que eu possa fazer referência e ver se o valor de uma célula está nessa matriz na coluna A da "Pasta de trabalho A".

Isto é o que eu tenho até agora para essa matriz:

Dim StrArray() As String
Dim TotalRows As Long
Dim X As Long

Workbooks.Open Filename:="filepath", ReadOnly:=True

With Workbooks("file").Worksheets("sheet")
    TotalRows = Rows(Rows.Count).End(xlUp).Row
    ReDim StrArray(1 To TotalRows)
    For X = 2 To TotalRows
        StrArray(X) = Cells(X, 1).Value
    Next X
End With

Esta parte da matriz funciona bem, confirmei que está funcionando corretamente exibindo todos os valores da matriz em um MsgBox. O problema surge quando tento referenciar essa matriz na "Pasta de trabalho A" para verificar se o valor de uma célula está nessa matriz.

Isto é o que eu tenho para esse código:

For RowCounter = LastRow To 1 Step -1
    If IsInArray(Range("B" & RowCounter).Value, StrArray) Then
        Range("K" & RowCounter).Value = "MATCH"
    End If
Next RowCounter

Workbooks("file").Close SaveChanges:=False

Aqui está a função que estou usando:

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = stringToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False

End Function

Ele não coloca o valor "MATCH" na coluna K. Eu tentei solucionar problemas colocando um MsgBox na instrução If para ver se ele está correspondendo ao valor da matriz, e isso me deu um loop sem fim do MsgBox. Se for importante, atualmente existe texto na coluna K sobre o qual este código está escrevendo.

microsoft-excel worksheet-function

2 respostas

  1. Se eu estivesse resolvendo esse problema, eu me recusaria a usar um array em favor do método MATCH embutido :

    Sub markCellsIfPresent()
Const DICTIONARY_WORKBOOK As String = "filepath"
Const DICTIONARY_WORKSHEET = "sheet"
Dim wsActive As Worksheet
Dim rValidate As Range
Dim oCell As Range
Dim wbDictionary As Workbook
Dim wsDictionary As Worksheet
Dim rDictionary As Range
Dim searchRes As Variant

    Set wsActive = ActiveSheet
    Set rValidate = Application.Intersect(wsActive.UsedRange, wsActive.Columns(2))
    Application.ScreenUpdating = False
    Set wbDictionary = Workbooks.Open(Filename:=DICTIONARY_WORKBOOK, ReadOnly:=True)
    Set wsDictionary = wbDictionary.Worksheets(DICTIONARY_WORKSHEET)
    Set rDictionary = Application.Intersect(wsDictionary.UsedRange, wsDictionary.Columns(1))
        
    For Each oCell In rValidate.Cells
        searchRes = Application.Match(oCell.Text, rDictionary, 0)
        If Not IsError(searchRes) Then
Rem oCell in column B (2), we set mark to column K (11), so offset is 11-2=9
           oCell.Offset(0, 9).value = "MATCH"
        End If
    Next oCell
   
    wbDictionary.Close
    Application.ScreenUpdating = True
End Sub

    Obviamente, o código real deve ser mais longo - por exemplo, você precisa verificar se a pasta de trabalho "filepath" existe e está aberta, se há uma planilha chamada "sheet", se há dados lá e mais

    Este código resolve o problema, mas não responde sua pergunta sobre o uso de um array para essa finalidade.

    O código do array será um pouco mais longo porque precisamos de um procedimento auxiliar para preenchê-lo e de uma função para pesquisá-lo.

    Sub markCellsWithArray()
Const DICTIONARY_WORKBOOK As String = "filepath"
Const DICTIONARY_WORKSHEET = "sheet"
Dim wsActive As Worksheet
Dim rValidate As Range
Dim oCell As Range
Dim wbDictionary As Workbook
Dim wsDictionary As Worksheet
Dim rDictionary As Range
Dim StrArray As Variant

    Set wsActive = ActiveSheet
    Set rValidate = Application.Intersect(wsActive.UsedRange, wsActive.Columns(2))
    Application.ScreenUpdating = False
    Set wbDictionary = Workbooks.Open(Filename:=DICTIONARY_WORKBOOK, ReadOnly:=True)
    Set wsDictionary = wbDictionary.Worksheets(DICTIONARY_WORKSHEET)
    Set rDictionary = Application.Intersect(wsDictionary.UsedRange, wsDictionary.Columns(1))
Rem Collect values from dictionary to array (skip empty cells)
    StrArray = Array()
    For Each oCell In rDictionary.Cells
        If Not Trim(oCell.Text) = vbNullString Then Call AddIfNeed(Trim(oCell.Text), StrArray)
    Next oCell
    wbDictionary.Close
    Application.ScreenUpdating = True
Rem Mark cells in active sheet
    For Each oCell In rValidate.Cells
        If IsInArray(Trim(oCell.Text), StrArray) Then
           oCell.Offset(0, 9).value = "MATCH"
        End If
    Next oCell
End Sub
Sub AddIfNeed(ByVal key As String, aData As Variant)
Dim l&, r&, m&, N&, i&
    l = LBound(aData)
    r = UBound(aData) + 1
    N = r
    While (l < r)
        m = l + Int((r - l) / 2)
        If aData(m) < key Then l = m + 1 Else r = m
    Wend
    If r = N Then   ' Add to end of set
        ReDim Preserve aData(0 To N)
        aData(N) = key
    ElseIf aData(r) = key Then
' Already in the set, do nothing
    Else    ' Insert to set in correct place
        ReDim Preserve aData(0 To N)
        For i = N - 1 To r Step -1
            aData(i + 1) = aData(i)
        Next i
        aData(r) = key
    End If
End Sub

Private Function IsInArray(ByVal stringToBeFound As String, aData As Variant) As Boolean
Dim l&, r&, m&, N&, i&
    l = LBound(aData)
    r = UBound(aData) + 1
    N = r
    While (l < r)
        m = l + Int((r - l) / 2)
        If aData(m) < stringToBeFound Then l = m + 1 Else r = m
    Wend
    If r = N Then   ' Add to end of set
        IsInArray = False
    Else
        IsInArray = (aData(r) = stringToBeFound)    ' TRUE if found
    End If
End Function

    O truque do código auxiliar é usar uma busca binária , que é muito mais rápida do que a busca linear que você usa ao passar por um array não classificado elemento por elemento.

    Para implementar esse truque sem código auxiliar, você pode usar um objeto Dictionary - já está tudo lá e você não precisa se preocupar com sua própria implementação dos algoritmos clássicos.

    No entanto, teste ambos os procedimentos em conjuntos de dados suficientemente grandes e veja como o algoritmo de matriz supera o método MATCH integrado.

    • 1
  2. Best Answer

    O código do JohnSUN funciona bem, mas também descobri como fazer o caminho do array funcionar.

    Workbooks.Open Filename:="filepath", ReadOnly:=True

    With Workbooks("filename").Worksheets("sheetname")
        TotalRows = Rows(Rows.Count).End(xlUp).Row
        ReDim StrArray(1 To TotalRows)
        For X = 2 To TotalRows
            StrArray(X) = Cells(X, 1).Value
        Next X
    End With

    Workbooks("filename").Close SaveChanges:=False

    ActWS.Activate

    'Adds MATCH to applicable rows
    For RowCounter = LastRow To 1 Step -1
        If IsInArray(Range("B" & RowCounter).Value, StrArray) Then
            Range("K" & RowCounter).Value = "MATCH"
        End If
    Next RowCounter
End If

    O problema era quando "MATCH" estava sendo aplicado, ele estava colocando no arquivo errado. Então eu tive que reativar o arquivo que eu queria antes que o código fosse executado.

    • 0

relate perguntas