5 Sheets Find only values that appear on all sheets with VBA

[rkol297]

I have 5 Sheets and want to find only the values that appear in column A on all sheets with VBA, then copy those instances and create a list on a new sheet.

Any Code help would be appreciated.

 

[MickG]

Try this:_
NB:- This code will create a sixth sheet "Master" for the results.

[COLOR="Navy"]Sub[/COLOR] MG16Jul46
[COLOR="Navy"]Dim[/COLOR] sht [COLOR="Navy"]As[/COLOR] Worksheet, Dic [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Dic = CreateObject("scripting.dictionary")
Dic.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] sht [COLOR="Navy"]In[/COLOR] Worksheets
c = c + 1
   [COLOR="Navy"]If[/COLOR] c > 5 [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
    [COLOR="Navy"]With[/COLOR] sht
        [COLOR="Navy"]Set[/COLOR] Rng = .Range("A1", .Range("A" & Rows.Count).End(xlUp))
     [COLOR="Navy"]End[/COLOR] With

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        Dic.Add Dn.Value, c
    [COLOR="Navy"]Else[/COLOR]
       [COLOR="Navy"]If[/COLOR] InStr(Dic(Dn.Value), c) = 0 [COLOR="Navy"]Then[/COLOR] Dic(Dn.Value) = Dic(Dn.Value) & c
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]Next[/COLOR] sht
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Master"
[COLOR="Navy"]Set[/COLOR] sht = ActiveSheet

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] Dic.keys
    [COLOR="Navy"]If[/COLOR] Dic(K) = 12345 [COLOR="Navy"]Then[/COLOR]
        n = n + 1
        Sheets("Master").Cells(n, "A") = K
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick