COLLECT SPECIFIC INFO FROM MULTIPLE SHEETS TO 1 SPECIFIC POINT

xenios

Board Regular
Joined
Sep 4, 2020
Messages
91
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: 10
  • boards2.png
    boards2.png
    184.6 KB · Views: 10
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?
 
Upvote 0

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
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
 
Upvote 0
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:
 
Upvote 0

Forum statistics

Threads
1,213,522
Messages
6,114,112
Members
448,549
Latest member
brianhfield

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
Back
Top