Comparing Data from multiple spread-sheets and fish out wanted data into a separate spread-sheet organized per tab

[Harry_1234]

I have multiple tabs of data (named AB, BC, CD, EF, FG, GH, HI, IJ, JK, KL, LM, MN, NO, OP, PQ, QR, RS, ST, TU, UV, VW, WX, XY, YZ, Z00, Z01, Z02, Z03) in my "critical numbers spread-sheet" with wanted numbers per application identified in each tab but columns and rows are inconsistent. I have an other spread-sheet ("total inventory spreadsheet") with total inventory of all the numbers spread across two tabs along with the location name. I would like to compare my total inventory spreadsheet against wanted numbers spread-sheet and fish out all wanted numbers identified per location into it's own tab i.e. see if number from total inventory exists in "critical numbers spread-sheet", if so it goes into a separate tab (and the sheet name should be the location name from "total inventory spreadsheet" i.e. AB, BC etccc). Attached is what i am trying to accomplish? Also to note, critical numbers spread-sheet will have an extra two characters ("\+") in front of every number. Once I have the spread-sheet with all the wanted numbers identified with proper location code, I would like to specify a range, that gets assigned as forwarded value in sequential order for all the numbers across all the tabs.

 

[Harry_1234]

​

Ok, and about my post #17 according to 'Summary' workbook ?​

The summary results I attached in post #1 is not accurate. I made it up. The one on the hosted website is what I expect. Obviously I only provided two locations but you get the idea.

 

[Marc L]

According to your attachment a VBA demonstration as a starter​

to paste to the ThisWorkbook module of the 'AllNumbersExport20210416194139' workbook :​

Function IsOpened(BOOK) As Boolean
         On Error Resume Next
         IsOpened = IsObject(Workbooks(BOOK))
End Function

Sub Demo1()
      Const C = "critical numbers spreadsheet.xlsx", S = "Summary.xlsx"
        Dim oDic As Object, Ws As Worksheet, V, T$(), R&, Rf As Range, A$
        If Not (IsOpened(C) And IsOpened(S)) Then Beep: Exit Sub
        Set oDic = CreateObject("Scripting.Dictionary")
    For Each Ws In Worksheets
    For Each V In Ws.Range("C6", Ws.[C5].End(xlDown)).Value2
        oDic(CStr(V)) = Empty
    Next V, Ws
        ReDim T(1 To Rows.Count, 0)
        T(1, 0) = "Telephone Numbers"
        Application.ScreenUpdating = False
    For Each Ws In Workbooks(C).Worksheets
            R = 1
        With Ws.UsedRange
               Set Rf = .Find("\+*", , xlValues, , 2)
            If Not Rf Is Nothing Then
                    A = Rf.Address
                Do
                    T(R + 1, 0) = Mid$(Rf.Text, 3)
                    If oDic.Exists(T(R + 1, 0)) Then R = R + 1
                    Set Rf = .FindNext(Rf)
                Loop Until Rf.Address = A
            End If
        End With
        If R > 1 Then
            With Workbooks(S).Worksheets
                If IsError(Evaluate("ISREF('[" & S & "]" & Ws.Name & "'!A1)")) Then .Add(, .Item(.Count)).Name = Ws.Name _
                                                                               Else .Item(Ws.Name).UsedRange.Clear
               .Item(Ws.Name).[A1].Resize(R).Value2 = T
               .Item(Ws.Name).UsedRange.Columns.AutoFit
            End With
        End If
    Next
        Application.Speech.Speak "Done !", True
        Application.ScreenUpdating = True
        Set Rf = Nothing
        oDic.RemoveAll
        Set oDic = Nothing
End Sub

 

[Harry_1234]

According to your attachment a VBA demonstration as a starter​

to paste to the ThisWorkbook module of the 'AllNumbersExport20210416194139' workbook :​

Function IsOpened(BOOK) As Boolean
         On Error Resume Next
         IsOpened = IsObject(Workbooks(BOOK))
End Function

Sub Demo1()
      Const C = "critical numbers spreadsheet.xlsx", S = "Summary.xlsx"
        Dim oDic As Object, Ws As Worksheet, V, T$(), R&, Rf As Range, A$
        If Not (IsOpened(C) And IsOpened(S)) Then Beep: Exit Sub
        Set oDic = CreateObject("Scripting.Dictionary")
    For Each Ws In Worksheets
    For Each V In Ws.Range("C6", Ws.[C5].End(xlDown)).Value2
        oDic(CStr(V)) = Empty
    Next V, Ws
        ReDim T(1 To Rows.Count, 0)
        T(1, 0) = "Telephone Numbers"
        Application.ScreenUpdating = False
    For Each Ws In Workbooks(C).Worksheets
            R = 1
        With Ws.UsedRange
               Set Rf = .Find("\+*", , xlValues, , 2)
            If Not Rf Is Nothing Then
                    A = Rf.Address
                Do
                    T(R + 1, 0) = Mid$(Rf.Text, 3)
                    If oDic.Exists(T(R + 1, 0)) Then R = R + 1
                    Set Rf = .FindNext(Rf)
                Loop Until Rf.Address = A
            End If
        End With
        If R > 1 Then
            With Workbooks(S).Worksheets
                If IsError(Evaluate("ISREF('[" & S & "]" & Ws.Name & "'!A1)")) Then .Add(, .Item(.Count)).Name = Ws.Name _
                                                                               Else .Item(Ws.Name).UsedRange.Clear
               .Item(Ws.Name).[A1].Resize(R).Value2 = T
               .Item(Ws.Name).UsedRange.Columns.AutoFit
            End With
        End If
    Next
        Application.Speech.Speak "Done !", True
        Application.ScreenUpdating = True
        Set Rf = Nothing
        oDic.RemoveAll
        Set oDic = Nothing
End Sub

I tested this code. The one thing I noticed is it is bringing over the location names from "critical numbers spreadsheet" as shown below. It should actually bring the location name from 'AllNumbersExport20210416194139' workbook. The 'AllNumbersExport20210416194139' workbook has the numbers grouped by location correctly. The below sheet name should say "QRST Hub" instead of "QRST,SP,XP,TC".

Summary.xlsx
	A
1	Telephone Numbers
2	11235370000
3	11235370088
4	11235370266
5	11235370300
6	11235370533
7	11235370545
8	11235370800
9	11235370830
10	11235370899
11	11235371011
12	11235371020
13	11235371024
14	11235371027
15	11235371042
16	11235371068
17	11235371069
18	11235371090
19	11235371096
20	11235371097
21	11235371098
22	11235371783
23	11235372268
24	11235372287
25	11235372301
26	11235372367
27	11235373030
28	11235373569
29	11235373727
30	11235375100
31	11235376597
32	11235376977
33	11235377722
34	11235378377
35	11235378388
36	11235378736
37	11235379985
38	11236620317
39	11236620319
40	11236620324
41	11236620335
42	11236620433
43	11236620792
44	11236620793
45	11236621111
46	11236621600
47	11236621700
48	11236621832
QRST,SP,XP,TC

 

[Marc L]

My revised demonstration which replaces all the previous :​

Function IsOpened(BOOK) As Boolean
         On Error Resume Next
         IsOpened = IsObject(Workbooks(BOOK))
End Function

Sub Demo1r()
      Const C = "critical numbers spreadsheet.xlsx", S = "Summary.xlsx"
        Dim oDic As Object, Ws As Worksheet, V, W, R&, K$, X, T$(), Rf As Range
        If Not (IsOpened(C) And IsOpened(S)) Then Beep: Exit Sub
        Set oDic = CreateObject("Scripting.Dictionary")
    For Each Ws In Worksheets
        With Ws.Range("A6", Ws.[A5].End(xlDown)).Columns
            V = .Item(1).Value2
            W = .Item(3).Value2
        End With
    For R = 1 To UBound(V)
           K = W(R, 1)
           X = oDic(K)
        If X = "" Then
            oDic(K) = V(R, 1)
        ElseIf V(R, 1) <> X Then
            Debug.Print K
            MsgBox "Several locations for " & K, vbExclamation, "Duplicate"
            oDic.RemoveAll
            Set oDic = Nothing
            Exit Sub
        End If
    Next R, Ws
        ReDim T(1 To Rows.Count, 0)
        T(1, 0) = "Telephone Numbers"
        Application.ScreenUpdating = False
    For Each Ws In Workbooks(S).Worksheets
        Ws.UsedRange.Clear
    Next
    For Each Ws In Workbooks(C).Worksheets
            R = 1
        With Ws.UsedRange
               Set Rf = .Find("\+*", , xlValues, , 2)
            If Not Rf Is Nothing Then
                    K = Rf.Address
                Do
                    T(R + 1, 0) = Mid$(Rf.Text, 3)
                    If oDic.Exists(T(R + 1, 0)) Then R = R + 1
                    Set Rf = .FindNext(Rf)
                Loop Until Rf.Address = K
            End If
        End With
        If R > 1 Then
                 K = oDic(T(2, 0))
            With Workbooks(S).Worksheets
                 If IsError(Evaluate("ISREF('[" & S & "]" & K & "'!A1)")) Then .Add(, .Item(.Count)).Name = K
                .Item(K).[A1].Resize(R).Value2 = T
                .Item(K).UsedRange.Columns.AutoFit
            End With
        End If
    Next
        Application.Speech.Speak "Done !", True
        Application.ScreenUpdating = True
        Set Rf = Nothing
        oDic.RemoveAll
        Set oDic = Nothing
End Sub

 

[Harry_1234]

My revised demonstration which replaces all the previous :​

Function IsOpened(BOOK) As Boolean
         On Error Resume Next
         IsOpened = IsObject(Workbooks(BOOK))
End Function

Sub Demo1r()
      Const C = "critical numbers spreadsheet.xlsx", S = "Summary.xlsx"
        Dim oDic As Object, Ws As Worksheet, V, W, R&, K$, X, T$(), Rf As Range
        If Not (IsOpened(C) And IsOpened(S)) Then Beep: Exit Sub
        Set oDic = CreateObject("Scripting.Dictionary")
    For Each Ws In Worksheets
        With Ws.Range("A6", Ws.[A5].End(xlDown)).Columns
            V = .Item(1).Value2
            W = .Item(3).Value2
        End With
    For R = 1 To UBound(V)
           K = W(R, 1)
           X = oDic(K)
        If X = "" Then
            oDic(K) = V(R, 1)
        ElseIf V(R, 1) <> X Then
            Debug.Print K
            MsgBox "Several locations for " & K, vbExclamation, "Duplicate"
            oDic.RemoveAll
            Set oDic = Nothing
            Exit Sub
        End If
    Next R, Ws
        ReDim T(1 To Rows.Count, 0)
        T(1, 0) = "Telephone Numbers"
        Application.ScreenUpdating = False
    For Each Ws In Workbooks(S).Worksheets
        Ws.UsedRange.Clear
    Next
    For Each Ws In Workbooks(C).Worksheets
            R = 1
        With Ws.UsedRange
               Set Rf = .Find("\+*", , xlValues, , 2)
            If Not Rf Is Nothing Then
                    K = Rf.Address
                Do
                    T(R + 1, 0) = Mid$(Rf.Text, 3)
                    If oDic.Exists(T(R + 1, 0)) Then R = R + 1
                    Set Rf = .FindNext(Rf)
                Loop Until Rf.Address = K
            End If
        End With
        If R > 1 Then
                 K = oDic(T(2, 0))
            With Workbooks(S).Worksheets
                 If IsError(Evaluate("ISREF('[" & S & "]" & K & "'!A1)")) Then .Add(, .Item(.Count)).Name = K
                .Item(K).[A1].Resize(R).Value2 = T
                .Item(K).UsedRange.Columns.AutoFit
            End With
        End If
    Next
        Application.Speech.Speak "Done !", True
        Application.ScreenUpdating = True
        Set Rf = Nothing
        oDic.RemoveAll
        Set oDic = Nothing
End Sub

Thank you!! This works like a charm.