代码之家 › 专栏 › 技术社区 › Maldred

在二维数组中查找现有字符串

excel-vba vba excel

Maldred · 技术社区 · 7 年前

代码:

Private Sub LoadData()

   cDOC_DEBUG "Loading document data..."
   Dim x As Long  'Column Data - there is another function that reads when x = 0 = header; else every other value is considered "data"
   Dim y As Long 

   With dataWS
      For x = 1 To LR - 1
         For y = 1 To LC - 1
            If (IsInArray(.Cells(x + 1, y + 1).value, pData())) Then
               cDOC_DEBUG "Added: " & .Cells(x + 1, y + 1).value
               pData(x, y) = Trim(.Cells(x + 1, y + 1).value)
            End If
         Next y
      Next x
   End With

End Sub

Private Function IsInArray(stringToBeFound As String, arrString As Variant) As Boolean
   IsInArray = (UBound(Filter(arrString, stringToBeFound)) > -1)
End Function

Private Sub cDOC_DEBUG(debugText As String)
   If (ThisWorkbook.Worksheets("Settings").Cells(3, 2)) Then
      Debug.Print debugText
   End If
End Sub

在我开始实现 IsInArray 功能。我可以看出这与它在一维数组中搜索有关,而我的数组是二维的;所以它得到的类型不匹配错误是有意义的。

电子表格中的每一行都是一段与其自身相关的信息。

电子表格中的初始数据:

        A           B           C           D
1    header1     header2     header3     header4
2       a           b           c           d
3       w           x           y           z
4       a           h           j           j
5       a           b           j           d
6       w           x           u           z

        0           1           2           3
0    header1     header2     header3     header4
1       a           b           c           d
2       w           x           y           z
3       a           h           j           j

因为Excel第5行和第6行的Header1、Header2和Header4的值与Excel第2行和第3行的值相同,所以不会将其读入数组。

我将如何匹配上述条件以不包含行中的重复项。

Sudo代码示例:

如果(要添加的值与列Header1&Header2&Header3中的所有值匹配,则

不添加到数组

我知道的另一个问题是,这个数组中会有空白数据;我可以做些什么来删除这些数据,还是必须为数组槽创建另一个索引来跟踪这些数据?

2 回复 | 直到 7 年前

QHarr 7 年前

可以循环行/列并使用 Index 从数组中分割行/列并使用 Match 测试搜索值是否在该列中。结合 Count 测试有无重复。如果计数等于列数忽略值(或列计数-1。。。请参阅下一条注释==>)。不完全确定这个虚构的专栏。是否要在开始时用一个额外的空列进行标注?

行版本:

存在:

Option Explicit
Public Sub CheckRow()
    Dim arr(), i As Long
    arr = [A1:D6].Value                          '<==2D array created

    For i = LBound(arr, 1) To UBound(arr, 1)     '<== loop rows
        'look in each row for x and if found exit loop and indicate row where found
        If Not IsError(Application.Match("x", Application.WorksheetFunction.Index(arr, i, 0), 0)) Then
            Debug.Print "value found in column " & i
            Exit For
        End If
    Next
End Sub

重复项:

Option Explicit
Public Sub CheckRow()
    Dim arr(), i As Long
    arr = [A1:D6].Value                          '<==2D array created

    For i = LBound(arr, 1) To UBound(arr, 1)     '<== loop rows
        'look in each row for more than one "B" and if found exit loop and indicate row where found
         If Application.Count(Application.Match(Application.WorksheetFunction.Index(arr, i, 0), "B", 0)) > 1 Then
            Debug.Print i
            Exit For
        End If
    Next
End Sub

存在:

Option Explicit
Public Sub CheckColumn()
    Dim arr(), i As Long
    arr = [A1:D6].Value                          '<==2D array created

    For i = LBound(arr, 2) To UBound(arr, 2)     '<== loop columns
        'look in each column for x and if found exit loop and indicate column where found
        If Not IsError(Application.Match("x", Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(arr, 0, i)), 0)) Then
            Debug.Print "value found in column " & i
            Exit For
        End If
    Next
End Sub

重复项:

你可以用要检查整个列中的重复项,请再次使用 索引 :

Option Explicit
Public Sub CheckColumn()
    Dim arr(), i As Long
    arr = [A1:D6].Value                          '<==2D array created

    For i = LBound(arr, 2) To UBound(arr, 2)     '<== loop columns
        'look in each column for more than one "B" and if found exit loop and indicate column where found
         If Application.Count(Application.Match(Application.WorksheetFunction.Transpose(Application.WorksheetFunction.Index(arr, 0, i)), "B", 0)) > 1 Then
            Debug.Print i
            Exit For
        End If
    Next
End Sub

T.M. 7 年前

使用高级 Index 功能

. 你会得到一个2-dim(1-based)数组 v 使用列A、B和D的唯一数据集。

在下面。

Sub getUniqueRows()
Dim dict As Object, v, i&, ii&, n&, currRow$
Set dict = CreateObject("Scripting.Dictionary")         ' late binding dictionary
With ThisWorkbook.Worksheets("MySheet")                 ' << change to your sheet name
  n = .Cells(.Rows.Count, "A").End(xlUp).Row - 1     ' n items (omitting header line)
' [1] get data
  v = .Range("A2:D" & n + 1).Value
' [2a]remove column C (i.e. allow columns 1, 2 and 4 only)
  v = Application.Index(v, Evaluate("row(1:" & n & ")"), Array(1, 2, 4))
' [2b] check for unique ones
  For i = 1 To n
     currRow = Join(Application.Index(v, i, 0), ",") ' build string of cells A,B & D
     If Not dict.Exists(currRow) Then dict.Add currRow, i
  Next i
' [3] remove duplicate rows
  v = Application.Transpose(Application.Index(v, dict.Items, Evaluate("row(1:" & 3 & ")")))
' [4] write data to any wanted range
  .Range("F:H") = ""                                 ' clear rows
  .Range("F2").Resize(UBound(v), 3) = v              ' write data
End With
Set dict = Nothing
End Sub

注意

这个 dict.Items 第[3]节中的集合是字典中找到的所有项目编号的数组,允许 索引 函数仅获取这些项。

看到了吗 Insert new first column in datafield array without loops or API call

编辑-维护C列中的值

仅使用A、B和D列;C列不包括在条件中

如果只想检查A、B和D中的值,但要保持 C值优化

Sub getUniqueRows2()
Dim dict As Object, v, i&, n&, j&, currRow$
Set dict = CreateObject("Scripting.Dictionary")          ' late binding dictionary
With ThisWorkbook.Worksheets("MySheet")                  ' << change to your sheet name
     n = .Cells(.Rows.Count, "A").End(xlUp).Row - 1      ' items counter  (omitting header line)
   ' [1] get data
     v = .Range("A2:D" & n + 1).Value
   ' [2] check for unique ones
     For i = 1 To UBound(v)
       ' assign ONLY criteria of 1st, 2nd & 4th column to string value currRow
         currRow = ""
         For j = 0 To 2: currRow = currRow & v(i, Array(1, 2, 4)(j)) & ",": Next j
       ' add first unique occurrence to dictionary
         If Not dict.Exists(currRow) Then                 ' add first occurrence
             If Len(currRow) > 3 Then dict.Add currRow, i ' ... and ignore empty values
         End If
     Next i
   ' [3] remove duplicate rows
     v = Application.Transpose(Application.Index(v, dict.Items, Evaluate("row(1:" & 4 & ")")))
   ' [4] write resulting array values anywhere, e.g. to columns F:I
     .Range("F:I") = ""                                   ' clear rows
     .Range("F2").Resize(UBound(v), 4) = v                ' write data
End With
Set dict = Nothing
End Sub