多个sheet的内容比较找到交集

ymsh1234

       sheet1、sheet2、sheet3分别有每个月每个点的水果销售情况。想知道那种水果在三家店都有销售，汇总在sheet4里面。

一把小刀闯天下

Option Explicit

Const NUM = 6 '共几个月

Sub test()
  Dim sht, arr, i, j, k
  ReDim dic(1 To NUM)
  For i = 1 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  sht = Split("sheet1 sheet1 sheet3") '分表名称
  For i = 0 To UBound(sht)
    arr = Sheets(sht(i)).[a1].CurrentRegion
    For j = 1 To NUM
      For k = 3 To UBound(arr, 1)
        If Len(arr(k, j)) Then dic(j)(arr(k, j)) = vbNullString
  Next k, j, i
  For i = 1 To NUM
    With Sheets("sheet4").Cells(3, i) '输出
      .Resize(Rows.Count - 2).ClearContents
      .Resize(dic(i).Count) = Application.Transpose(dic(i).keys)
    End With
  Next
End Sub

jiminyanyan

2楼老师写的结果不是交集的意思。。。

一把小刀闯天下

jiminyanyan 发表于 2018-6-9 21:38
2楼老师写的结果不是交集的意思。。。

'嗯，看了一下我求的是合集，修改成交集了

Option Explicit

Const NUM = 6 '共几个月

Sub test()
  Dim sht, arr, i, j, k, key
  ReDim dic(1 To NUM)
  For i = 1 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  sht = Split("sheet1 sheet1 sheet3") '分表名称
  For i = 0 To UBound(sht)
    arr = Sheets(sht(i)).[a1].CurrentRegion
    For j = 1 To NUM
      For k = 3 To UBound(arr, 1)
        If Len(arr(k, j)) > 0 Then dic(j)(arr(k, j)) = dic(j)(arr(k, j)) + 1
  Next k, j, i
  ReDim n(1 To NUM), arr(1 To Rows.Count, 1 To NUM)
  k = 0
  For i = 1 To NUM
    For Each j In dic(i).keys
      If dic(i)(j) = UBound(sht) + 1 Then
        n(i) = n(i) + 1: arr(n(i), i) = j
        If k < n(i) Then k = n(i)
      End If
  Next j, i
  With Sheets("sheet4").[a3]
    .Resize(Rows.Count - 2, 12).ClearContents
    If k > 0 Then .Resize(k, UBound(arr, 2)) = arr
  End With
End Sub

ymsh1234

非常感谢老师，我自己调整了一下，现在也可以实现4个表或者5个表进行交集比较
非常谢谢