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