Excel 从原始数据中提取多张图纸中的相似数据

以下是我试图实现的目标： 我在表“dat1”中有一个列表；这是原始数据（第1列）。 我有表“min1”和“min2”，它们都包含类似于表“dat1”第1列数据n的数据，尽管这两个列表都比原始数据短

要使其更直观，请执行以下操作：

Data "dat1"
a
b
c
d
e
f
g

这正是我所期望的：

Sub extract()

    Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
    Dim lr1 As Long, lr2 As Long, lr3 As Long
    Dim chk1 As Variant, chk2 As Variant, chk3 As Variant
    Dim i As Long, j As Long, k As Long

    Set sht1 = ThisWorkbook.Worksheets("dat1") 'original data range
    Set sht2 = ThisWorkbook.Worksheets("min1") 'partial data resembling dat1
    Set sht3 = ThisWorkbook.Worksheets("min2") 'partial data resembling dat1
    Set sht4 = ThisWorkbook.Worksheets("EndResult") 'orginal data minus resembling data from min1 and min2

    lr1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
    lr2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
    lr3 = sht3.Cells(sht3.Rows.Count, "A").End(xlUp).Row


    chk1 = sht1.Range("A1:B" & lr1).Value
    chk2 = sht2.Range("A1:A" & lr2).Value
    chk3 = sht3.Range("A1:A" & lr3).Value

    For i = LBound(chk1) To UBound(chk1)
    For j = LBound(chk2) To UBound(chk2)
    For k = LBound(chk3) To UBound(chk3)

        If chk1(i, 1) <> chk2(j, 1) And chk1(i, 1) <> chk3(k, 1) Then
            If IsEmpty(sht4.[A1].Value) Then
                sht4.[A1].Value = chk1(i, 1)
            Else: sht4.Cells(sht4.Rows.Count, "A").End(xlUp).Offset(1).Value = chk1(i, 1)
            End If
        End If

    Next
    Next
    Next

End Sub

Sub-extract（）
尺寸sht1作为工作表，sht2作为工作表，sht3作为工作表，sht4作为工作表
尺寸lr1为长，lr2为长，lr3为长
尺寸chk1为变型，chk2为变型，chk3为变型
我长，j长，k长
设置sht1=ThisWorkbook.Worksheets（“dat1”）的原始数据范围
设置sht2=ThisWorkbook.Worksheets（“min1”）部分数据为dat1
设置sht3=ThisWorkbook.Worksheets（“min2”）部分数据为dat1
Set sht4=ThisWorkbook.Worksheets（“EndResult”）'原始数据减去来自min1和min2的相似数据
lr1=sht1.Cells（sht1.Rows.Count，“A”）.End（xlUp）.Row
lr2=sht2.Cells（sht2.Rows.Count，“A”）.End（xlUp.Row）
lr3=sht3.Cells（sht3.Rows.Count，“A”）.End（xlUp）.Row
chk1=sht1.范围（“A1:B”和lr1）.值
chk2=sht2.范围（“A1:A”和lr2）.值
chk3=sht3.范围（“A1:A”和lr3）.值
对于i=LBound（chk1）至UBound（chk1）
对于j=LBound（chk2）至UBound（chk2）
对于k=LBound（chk3）至UBound（chk3）
如果chk1（i，1）chk2（j，1）和chk1（i，1）chk3（k，1），那么
如果为空（sht4[A1].Value），则
sht4[A1]。值=chk1（i，1）
Else:sht4.Cells（sht4.Rows.Count，“A”）.End（xlUp）.Offset（1）.Value=chk1（i，1）
如果结束
如果结束
下一个
下一个
下一个
端接头

它不起作用，但我不知道为什么。

---

谁能解释/帮助我？

您可以使用

AutoFilter（）

请参见我的代码，其中我：

---

• silitly更改了代码（请参见

  ”您可以使用VBA过滤器功能。
  我将数据读入阵列以加快处理速度：
  
  Option Explicit
  Sub extract()
      Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
      Dim vdat1 As Variant, vmin1 As Variant, vmin2 As Variant, vRes As Variant
      Dim V As Variant
  
  With ThisWorkbook
      Set sht1 = .Worksheets("dat1")
      Set sht2 = .Worksheets("min1")
      Set sht3 = .Worksheets("min2")
      Set sht4 = .Worksheets("EndResult")
  End With
  
  With sht1
      vdat1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  With sht2
      vmin1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  With sht3
      vmin2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  
  'make vdat a 1D array
  vdat1 = WorksheetFunction.Transpose(vdat1)
  
  'filter out the mins
  For Each V In vmin1
      vdat1 = Filter(vdat1, V, False, vbTextCompare)
  Next V
  
  For Each V In vmin2
      vdat1 = Filter(vdat1, V, False, vbTextCompare)
  Next V
  
  'make vdat a 2D array
  vdat1 = WorksheetFunction.Transpose(vdat1)
  
  'write the results
  Dim rRes As Range
  Set rRes = sht4.Cells(1, 1).Resize(rowsize:=UBound(vdat1))
  
  With rRes
      .EntireColumn.Clear
      .Value = vdat1
      .EntireColumn.AutoFit
  End With
  
  End Sub
  
  你能详细解释一下你所说的“不工作”是什么意思吗？你有错误吗？错误的结果吗？什么？上面代码的结果=``a a a b b b c c c d d d d e e f f f f f f g g``所以你希望你的第四页包含
  dat1
  上的记录，而不是
  min1
  和
  min2
  上的记录，这正是，但min1和min2上的记录当然，但我相信你的意思是这样的。所以dat1减去min1的相似数据减去min2的相似数据换句话说：dat1中的所有数据都类似于min1或min2中的数据，除了：b和f。我希望这些非相似值会显示在sheet EndResultThanks中。这种方法没有给出所需的结果（在我的示例数据中，它给出了e和g作为结果），但我认为这将有助于我正确理解。我根据您的问题进行了测试，非常数据，它在“EndResult”表中给出了b和f。因此，要么您没有使用我的非常代码，要么您的问题非常数据。此代码完全符合我的意思。感谢您在代码中一步一步地阐明这一点
  Result = dat1 - min1 - min2 = "EndResult"
  b
  f
  
  Sub extract()
  
      Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
      Dim lr1 As Long, lr2 As Long, lr3 As Long
      Dim chk1 As Variant, chk2 As Variant, chk3 As Variant
      Dim i As Long, j As Long, k As Long
  
      Set sht1 = ThisWorkbook.Worksheets("dat1") 'original data range
      Set sht2 = ThisWorkbook.Worksheets("min1") 'partial data resembling dat1
      Set sht3 = ThisWorkbook.Worksheets("min2") 'partial data resembling dat1
      Set sht4 = ThisWorkbook.Worksheets("EndResult") 'orginal data minus resembling data from min1 and min2
  
      lr1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
      lr2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
      lr3 = sht3.Cells(sht3.Rows.Count, "A").End(xlUp).Row
  
  
      chk1 = sht1.Range("A1:B" & lr1).Value
      chk2 = sht2.Range("A1:A" & lr2).Value
      chk3 = sht3.Range("A1:A" & lr3).Value
  
      For i = LBound(chk1) To UBound(chk1)
      For j = LBound(chk2) To UBound(chk2)
      For k = LBound(chk3) To UBound(chk3)
  
          If chk1(i, 1) <> chk2(j, 1) And chk1(i, 1) <> chk3(k, 1) Then
              If IsEmpty(sht4.[A1].Value) Then
                  sht4.[A1].Value = chk1(i, 1)
              Else: sht4.Cells(sht4.Rows.Count, "A").End(xlUp).Offset(1).Value = chk1(i, 1)
              End If
          End If
  
      Next
      Next
      Next
  
  End Sub
  
  Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
  Dim lr1 As Long, lr2 As Long, lr3 As Long
  Dim chk2 As Variant, chk3 As Variant
  Dim chk1Rng As Range '<--
  Dim i As Long, j As Long, k As Long
  
  Set sht1 = ThisWorkbook.Worksheets("dat1") 'original data range
  Set sht2 = ThisWorkbook.Worksheets("min1") 'partial data resembling dat1
  Set sht3 = ThisWorkbook.Worksheets("min2") 'partial data resembling dat1
  Set sht4 = ThisWorkbook.Worksheets("EndResult") 'orginal data minus resembling data from min1 and min2
  
  lr1 = sht1.Cells(sht1.Rows.Count, "A").End(xlUp).Row
  lr2 = sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
  lr3 = sht3.Cells(sht3.Rows.Count, "A").End(xlUp).Row
  
  
  Set chk1Rng = sht1.Range("A1:B" & lr1) ' <-- set data range
  chk2 = sht2.Range("A1:A" & lr2).Value
  chk3 = sht3.Range("A1:A" & lr3).Value
  
  
  '--------------
  With chk1Rng ' reference data range
      .Rows(1).Insert ' insert helper row for dummy header
      With .Offset(-1).Resize(.Rows.Count + 1) ' enlarge data rage to embrace newly inserted row
          .Cells(1, 1).Value = "h1" ' filled newly inserted rows with dummy header
          .AutoFilter field:=1, Criteria1:=Application.Transpose(chk2), Operator:=xlFilterValues ' filter referenced range on its 1st column with 'min1' values
          .AutoFilter field:=1, Criteria1:=Application.Transpose(chk3), Operator:=xlFilterValues ' filter referenced range on its 1st column with 'min2' values
          .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy sht4.Cells(1, 1) ' copy unfiltered cells to 'sht4'
          .Parent.AutoFilterMode = False ' remove autofilter
          .Rows(1).EntireRow.Delete xlUp ' delete "helper" row
      End With
  End With
  '--------------
  
  Option Explicit
  Sub extract()
      Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet, sht4 As Worksheet
      Dim vdat1 As Variant, vmin1 As Variant, vmin2 As Variant, vRes As Variant
      Dim V As Variant
  
  With ThisWorkbook
      Set sht1 = .Worksheets("dat1")
      Set sht2 = .Worksheets("min1")
      Set sht3 = .Worksheets("min2")
      Set sht4 = .Worksheets("EndResult")
  End With
  
  With sht1
      vdat1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  With sht2
      vmin1 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  With sht3
      vmin2 = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  
  'make vdat a 1D array
  vdat1 = WorksheetFunction.Transpose(vdat1)
  
  'filter out the mins
  For Each V In vmin1
      vdat1 = Filter(vdat1, V, False, vbTextCompare)
  Next V
  
  For Each V In vmin2
      vdat1 = Filter(vdat1, V, False, vbTextCompare)
  Next V
  
  'make vdat a 2D array
  vdat1 = WorksheetFunction.Transpose(vdat1)
  
  'write the results
  Dim rRes As Range
  Set rRes = sht4.Cells(1, 1).Resize(rowsize:=UBound(vdat1))
  
  With rRes
      .EntireColumn.Clear
      .Value = vdat1
      .EntireColumn.AutoFit
  End With
  
  End Sub