COLLECT SPECIFIC INFO FROM MULTIPLE SHEETS TO 1 SPECIFIC POINT

[xenios]

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

EXAMPLE.xlsm

drive.google.com

 

[DanteAmor]

I have various doubts:
- You want a formula to fill the yellow cells.
- Or a formula to fill the green cells.
- Or a macro to fill the entire HOTELS sheet, that is, the HOTELS sheet is empty and you want to collect the information from all the sheets.
I assume you have more than 5 sheets of hotel names.
- Could you explain in more detail what you have on the HOTELS sheet and what you want as a result.

 

[xenios]

I have various doubts:
- You want a formula to fill the yellow cells.
- Or a formula to fill the green cells.
- Or a macro to fill the entire HOTELS sheet, that is, the HOTELS sheet is empty and you want to collect the information from all the sheets.
I assume you have more than 5 sheets of hotel names.
- Could you explain in more detail what you have on the HOTELS sheet and what you want as a result.

No the yellow sells, is what I'mm getting by default.
What I need is the formula to collect the information from the sheets in separate cells (as in green example 1) or in one cell (green example 2), suppose it's more difficult
I have about 300 sheets in general.

Let say I have a hotel that has AI, HB, BB option, by default I'm getting AI from the system, but the sheet has all the info, but it's never in specific row or column.

is it more understandable now?

 

[DanteAmor]

but it's never in specific row or column

At least the column title says "Boarding" on all the sheets?

The first name in cell A3 on the HOTELS sheet says "ADELAIS HOTEL" without Underscore, but the sheet name says: "ADELAIS_HOTEL" with Underscore.
Does that mean that the name in the cell does not match the name of the sheet, does this happen with all sheets or is it just the Underscore?

Which solution do you want 1 or 2. The 2 are possible with a macro. Do you want the macro?

 

[DanteAmor]

We have another problem. There are names in the cell like this:
"ALEXANDROS APARTMENTS" but the sheet name has a space at the end of the name:
"ALEXANDROS APARTMENTS "

Let me know if you can fix those problems in your file.
I'm going to find out how to fix it with the hyperlink you have in each cell.

 

[xenios]

Yes, you are right.
I'm renaming the sheets with the following code, from the name in A7 , may be there's something, that can avoid the space. (it renames the sheet name with the name from A7 until brakets, or to 2 words if it's too long.
Sub rename ()
Dim Ws As Worksheet
Dim Nme As String

With CreateObject("scripting.dictionary")
For Each Ws In WorkSheets
Nme = Split(Ws.Range("A7").Value, " (")(0)
If Len(Nme) > 31 Then Nme = Split(Nme, " ", 3)(0) & " " & Split(Nme, " ", 3)(1)
If Not .Exists(Nme) Then
.Add Nme, 0
Ws.Name = Nme
Else
.Item(Nme) = .Item(Nme) + 1
Ws.Name = Nme & .Item(Nme)
End If
Next Ws
End With
End Sub

 

[DanteAmor]

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.

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

 

[xenios]

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.

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

No didn't find the solution yet.
But waw it's really works, to tell the truth never imagined it's possible.
Thanks A LOT!!!!!

 

[xenios]

No didn't find the solution yet.
But waw it's really works, to tell the truth never imagined it's possible.
Thanks A LOT!!!!!

When the name is not the same, can it check with the 1st 2 words?

 

[xenios]

No didn't find the solution yet.
But waw it's really works, to tell the truth never imagined it's possible.
Thanks A LOT!!!!!

Is it possible, when the name is not the same to check by 1st 2 words?