COLLECT SPECIFIC INFO FROM MULTIPLE SHEETS TO 1 SPECIFIC POINT

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
Dear All,

If this is in general possible.
I have the 1st page where the system gives me only the base board of the hotels, in the sheets I have all of the boards available. Can I somehow collect this information automatically.
Please see the example how it looks like.
Or fllow the link for the example file
 

Attachments

  • boards1.png
    boards1.png
    195.1 KB · Views: 8
  • boards2.png
    boards2.png
    184.6 KB · Views: 8

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
Ok, if you already fixed the problems with the names of the sheets (underscore or spaces) and in the cell it has the same as the name of the sheet, then try the following.

The following macro is for solution number 2. The results will be in column D.

VBA Code:
Sub Collect_Info()
  Dim sh1 As Worksheet, sh As Worksheet, dic As Object
  Dim a As Variant, b() As Variant, c As Variant
  Dim i As Long, j As Long, lr As Long, f As Range
  Dim sName As String, cad As String, existe As Boolean
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("HOTELS")
  Set dic = CreateObject("Scripting.Dictionary")
 
  sh1.Range("D1", sh1.Cells(8, Columns.Count)).Value = ""
  a = sh1.Range("A3", sh1.Range("A" & Rows.Count).End(3)).Value2
  ReDim c(1 To UBound(a), 1 To 1)
  dic.comparemode = vbTextCompare
 
  For i = 1 To UBound(a)
    sName = a(i, 1)
    existe = False

    If Evaluate("ISREF('" & sName & "'!A1)") Then
      existe = True
    Else
      sName = Replace(sName, " ", "_")
      If Evaluate("ISREF('" & sName & "'!A1)") Then
        existe = True
      End If
    End If
   
    If existe = True Then
      Set sh = Sheets(sName)
      Set f = sh.Cells.Find("Boarding", , xlValues, xlWhole)
      If Not f Is Nothing Then
        Erase b
        dic.RemoveAll
        cad = ""
        lr = sh.Cells(Rows.Count, f.Column).End(3).Row + 1
        b = sh.Range(sh.Cells(f.Offset(1).Row, f.Column), sh.Cells(lr, f.Column)).Value2
       
        For j = 1 To UBound(b)
          If b(j, 1) <> "" Then
            If Not dic.exists(b(j, 1)) Then
              cad = cad & b(j, 1) & "/ "
              dic(b(j, 1)) = Empty
            End If
          End If
        Next
        If cad <> "" Then c(i, 1) = Left(cad, Len(cad) - 2)
      End If
    End If
  Next
   
  sh1.Range("D3").Resize(UBound(c)).Value = c

  Application.ScreenUpdating = True
End Sub
Is it possible, when the name is not the same to check by 1st 2 words?
 

Some videos you may like

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
Is it possible, when the name is not the same to check by 1st 2 words?

Try this:

VBA Code:
Sub Collect_Info()
  Dim sh1 As Worksheet, sh As Worksheet, dic As Object
  Dim a As Variant, b() As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, f As Range
  Dim sName As String, sName_1 As String, cad As String
  Dim existe As Boolean, sName_2 As Variant
  
  Application.ScreenUpdating = False
  
  Set sh1 = Sheets("HOTELS")
  Set dic = CreateObject("Scripting.Dictionary")
  
  sh1.Range("D1", sh1.Cells(8, Columns.Count)).Value = ""
  a = sh1.Range("A3", sh1.Range("A" & Rows.Count).End(3)).Value2
  ReDim c(1 To UBound(a), 1 To 1)
  dic.comparemode = vbTextCompare
  
  For i = 1 To UBound(a)
    sName = a(i, 1)
    existe = False
    If Evaluate("ISREF('" & sName & "'!A1)") Then
      existe = True
    Else
      sName_1 = Replace(sName, " ", "_")
      If Evaluate("ISREF('" & sName_1 & "'!A1)") Then
        sName = sName_1
        existe = True
      Else
        sName_2 = Split(sName, " ")
        If UBound(sName_2) > 0 Then
          sName_1 = sName_2(0) & " " & sName_2(1)
          For k = 1 To Sheets.Count
            If LCase(Left(Sheets(k).Name, Len(sName_1))) = LCase(sName_1) Then
              sName = Sheets(k).Name
              existe = True
              Exit For
            End If
          Next
        End If
      End If
    End If
    
    If existe = True Then
      Set sh = Sheets(sName)
      Set f = sh.Cells.Find("Boarding", , xlValues, xlWhole)
      If Not f Is Nothing Then
        Erase b
        dic.RemoveAll
        cad = ""
        lr = sh.Cells(Rows.Count, f.Column).End(3).Row + 2
        b = sh.Range(sh.Cells(f.Offset(1).Row, f.Column), sh.Cells(lr, f.Column)).Value2
        
        For j = 1 To UBound(b)
          If b(j, 1) <> "" Then
            If Not dic.exists(b(j, 1)) Then
              cad = cad & b(j, 1) & "/ "
              dic(b(j, 1)) = Empty
            End If
          End If
        Next
        If cad <> "" Then
          c(i, 1) = Left(cad, Len(cad) - 2)
        Else
          c(i, 1) = "No data"
        End If
      Else
        c(i, 1) = "There is no word Boarding"
      End If
    Else
      c(i, 1) = "Sheet does not exist"
    End If
  Next
    
  sh1.Range("D3").Resize(UBound(c)).Value = c
  Application.ScreenUpdating = True
End Sub
 

xenios

Board Regular
Joined
Sep 4, 2020
Messages
88
Office Version
  1. 2016
Platform
  1. Windows
Try this:

VBA Code:
Sub Collect_Info()
  Dim sh1 As Worksheet, sh As Worksheet, dic As Object
  Dim a As Variant, b() As Variant, c As Variant
  Dim i As Long, j As Long, k As Long, lr As Long, f As Range
  Dim sName As String, sName_1 As String, cad As String
  Dim existe As Boolean, sName_2 As Variant
 
  Application.ScreenUpdating = False
 
  Set sh1 = Sheets("HOTELS")
  Set dic = CreateObject("Scripting.Dictionary")
 
  sh1.Range("D1", sh1.Cells(8, Columns.Count)).Value = ""
  a = sh1.Range("A3", sh1.Range("A" & Rows.Count).End(3)).Value2
  ReDim c(1 To UBound(a), 1 To 1)
  dic.comparemode = vbTextCompare
 
  For i = 1 To UBound(a)
    sName = a(i, 1)
    existe = False
    If Evaluate("ISREF('" & sName & "'!A1)") Then
      existe = True
    Else
      sName_1 = Replace(sName, " ", "_")
      If Evaluate("ISREF('" & sName_1 & "'!A1)") Then
        sName = sName_1
        existe = True
      Else
        sName_2 = Split(sName, " ")
        If UBound(sName_2) > 0 Then
          sName_1 = sName_2(0) & " " & sName_2(1)
          For k = 1 To Sheets.Count
            If LCase(Left(Sheets(k).Name, Len(sName_1))) = LCase(sName_1) Then
              sName = Sheets(k).Name
              existe = True
              Exit For
            End If
          Next
        End If
      End If
    End If
   
    If existe = True Then
      Set sh = Sheets(sName)
      Set f = sh.Cells.Find("Boarding", , xlValues, xlWhole)
      If Not f Is Nothing Then
        Erase b
        dic.RemoveAll
        cad = ""
        lr = sh.Cells(Rows.Count, f.Column).End(3).Row + 2
        b = sh.Range(sh.Cells(f.Offset(1).Row, f.Column), sh.Cells(lr, f.Column)).Value2
       
        For j = 1 To UBound(b)
          If b(j, 1) <> "" Then
            If Not dic.exists(b(j, 1)) Then
              cad = cad & b(j, 1) & "/ "
              dic(b(j, 1)) = Empty
            End If
          End If
        Next
        If cad <> "" Then
          c(i, 1) = Left(cad, Len(cad) - 2)
        Else
          c(i, 1) = "No data"
        End If
      Else
        c(i, 1) = "There is no word Boarding"
      End If
    Else
      c(i, 1) = "Sheet does not exist"
    End If
  Next
   
  sh1.Range("D3").Resize(UBound(c)).Value = c
  Application.ScreenUpdating = True
End Sub
Yes, much better this way!!! Thank you :love:
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,594
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

Watch MrExcel Video

Forum statistics

Threads
1,119,104
Messages
5,576,140
Members
412,700
Latest member
IIII
Top