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

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
46
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.
 

Attachments

  • critical numbers spread-sheet.PNG
    critical numbers spread-sheet.PNG
    110.4 KB · Views: 19
  • Total Inventory Spreadsheet.PNG
    Total Inventory Spreadsheet.PNG
    41.2 KB · Views: 19
  • Summary.PNG
    Summary.PNG
    47.4 KB · Views: 19

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
46
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.
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,567
Office Version
  1. 2010
Platform
  1. Windows
According to your attachment a VBA demonstration as a starter​
to paste to the ThisWorkbook module of the 'AllNumbersExport20210416194139' workbook :​
VBA Code:
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
 
Last edited:

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
46
According to your attachment a VBA demonstration as a starter​
to paste to the ThisWorkbook module of the 'AllNumbersExport20210416194139' workbook :​
VBA Code:
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
1Telephone Numbers
211235370000
311235370088
411235370266
511235370300
611235370533
711235370545
811235370800
911235370830
1011235370899
1111235371011
1211235371020
1311235371024
1411235371027
1511235371042
1611235371068
1711235371069
1811235371090
1911235371096
2011235371097
2111235371098
2211235371783
2311235372268
2411235372287
2511235372301
2611235372367
2711235373030
2811235373569
2911235373727
3011235375100
3111235376597
3211235376977
3311235377722
3411235378377
3511235378388
3611235378736
3711235379985
3811236620317
3911236620319
4011236620324
4111236620335
4211236620433
4311236620792
4411236620793
4511236621111
4611236621600
4711236621700
4811236621832
QRST,SP,XP,TC
 

Marc L

Well-known Member
Joined
Apr 5, 2021
Messages
1,567
Office Version
  1. 2010
Platform
  1. Windows
My revised demonstration which replaces all the previous :​
VBA Code:
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
 
Solution

Harry_1234

New Member
Joined
Aug 19, 2017
Messages
46
My revised demonstration which replaces all the previous :​
VBA Code:
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.
 

Forum statistics

Threads
1,143,907
Messages
5,721,439
Members
422,362
Latest member
elliotpat

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top