Searchable adressbook

[skaffapingvin]

Hi,

I am looking for an address book that is searchable.
I am imagining a table with the following columns:
Company name
Contact person
Street address
Postal code
City
Country
Telephone no
Email

Instead of scrolling through data or using filtering, I would like to have a search field and then have the search result show only the information of the company I am looking for.
I have searched but haven't found anything that ticks all the boxes. If anybody has any good examples of already existing templates or such it would be much appreciated if you could share this with me.

Bregs.

 

[Joe4]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

If you are using Excel 365, it seems like the new FILTER function would check all those boxes (I am talking about the FILTER function, not the old FILTER menu options).
See: FILTER function - Microsoft Support

 

[Logit]

Here are two examples. You can change the column header names to suit the fields you are seeking.

Internxt Drive – Private & Secure Cloud Storage

Internxt Drive – Private & Secure Cloud Storage

 

[Peter_SSs]

@Logit
Please refer to #4 of the Forum Rules, particularly the last 2 paragraphs.

 

[Logit]

Internxt Drive – Private & Secure Cloud Storage

'For More : http://merkez-ihayat.blogspot.com

Private Sub CommandButton1_Click()
Dim alan, satýrsayýsý, sonsatýr As Long
Set alan = Cells(1, 1).CurrentRegion
satýrsayýsý = alan.Rows.Count
sonsatýr = satýrsayýsý + 1
Cells(sonsatýr, 1).Select
End Sub

Private Sub TextBox1_Change()
Dim metin
On Error Resume Next
metin = TextBox1.Value
Set bul = Range("a2:a65536").Find(What:=metin)
Application.Goto Reference:=Range(bul.Address), Scroll:=False
Selection.AutoFilter field:=1, Criteria1:=TextBox1.Value & "*"
If metin = "" Then
Worksheets("Adres1").AutoFilterMode = False
End If
End Sub

Private Sub TextBox2_Change()
Dim metin2
On Error Resume Next
metin2 = TextBox2.Value
Set bul = Range("b2:b65536").Find(What:=metin2)
Application.Goto Reference:=Range(bul.Address), Scroll:=False
Selection.AutoFilter field:=2, Criteria1:=TextBox2.Value & "*"
If metin2 = "" Then
Worksheets("Adres1").AutoFilterMode = False
End If
End Sub

Internxt Drive – Private & Secure Cloud Storage

Option Explicit
'''Code provided by Randy Austin, Founder of Excel For Freelancers
''More Free Training at: https://www.excelforfreelancers.com/

Sub HideFilters()
With Sheet1
    .Shapes("ClearFilterBtn").Visible = msoFalse
    .Shapes("CloseFilterBtn").Visible = msoFalse
    .Shapes("OpenFilterBtn").Visible = msoCTrue
    .Range("D:E").EntireColumn.Hidden = True
End With
End Sub


Sub ShowFilters()
With Sheet1
    .Shapes("ClearFilterBtn").Visible = msoCTrue
    .Shapes("CloseFilterBtn").Visible = msoCTrue
    .Shapes("OpenFilterBtn").Visible = msoFalse
    .Range("D:E").EntireColumn.Hidden = False
End With
End Sub

Sub ClearFilters()
Sheet2.Range("Q4:BQ9999").ClearContents 'Clear Old Results
LoadFilters
Refre****emTable
End Sub

Sub LoadFilters()
Dim FiltRow, DataCol, LastItemFiltRow, LastItemRow, UniqueListItems As Long
Dim FiltType As String
StopCalc
Sheet2.Range("Q4:Y999").ClearContents 'Clear any old results
With Sheet1
.Range("A9").Value = True 'Set Filter Load To True
LastItemFiltRow = .Range("D999").End(xlUp).Row
'Clear existing Filter Range
.Range("ClearRange").Copy
.Range("D6:E" & LastItemFiltRow).PasteSpecial xlPasteAll 'Clear Filter Area
.Range("B6:B999").ClearContents
FiltRow = 6 'Start Filter Row at 6

For DataCol = 1 To 9 'Expand for larger data tables
    FiltType = Sheet2.Cells(2, DataCol).Value
 
 'On Text Type
    If FiltType = "Text" Then
        .Range("TextSearch").Copy
        .Range("D" & FiltRow).PasteSpecial xlPasteAll
        .Range("E" & FiltRow).Value = "Enter " & Sheet2.Cells(3, DataCol).Value & ":"
        .Range("B" & FiltRow).Value = DataCol + 16
        FiltRow = FiltRow + 2
      GoTo NextCol
    End If
        
    'On List Type Item
        If FiltType = "List" Then
             DeleteFilters 'Clear Old Criteria & Extract Named Ranges
            .Range("E" & FiltRow - 1).Value = Sheet2.Cells(3, DataCol).Value 'Header Name
            LastItemRow = Sheet2.Cells(99999, DataCol).End(xlUp).Row 'Last List Type Item in Column
            
            Sheet2.Range("M3:M9999").ClearContents
            Range(Sheet2.Cells(3, DataCol), Sheet2.Cells(LastItemRow, DataCol)).AdvancedFilter xlFilterCopy, CopyToRange:=Sheet2.Range("M3"), unique:=True
            UniqueListItems = Sheet2.Range("M999999").End(xlUp).Row - 3
            If UniqueListItems < 1 Then GoTo SkipItems
            .Range("ListSearch").Copy
               .Range("D" & FiltRow).PasteSpecial xlPasteAll
               .Range("D" & FiltRow & ":E" & FiltRow).Copy
            .Range("D" & FiltRow + 1 & ":E" & FiltRow + UniqueListItems - 1).PasteSpecial xlPasteAll
            .Range("E" & FiltRow & ":E" & FiltRow + UniqueListItems - 1).Value = Sheet2.Range("M4:M" & UniqueListItems + 3).Value
            .Range("B" & FiltRow & ":B" & FiltRow + UniqueListItems - 1).Value = Sheet2.Cells(3, DataCol).Value
            Sheet2.Range("M3:M9999").ClearContents
            FiltRow = FiltRow + UniqueListItems + 1
SkipItems:
            GoTo NextCol
        End If

     'On Date Type
    If FiltType = "Date" Then
    .Range("E" & FiltRow - 1).Value = Sheet2.Cells(3, DataCol).Value
        .Range("DateSearch").Copy
        .Range("D" & FiltRow).PasteSpecial xlPasteAll
        Range("B" & FiltRow).Value = DataCol + 26 'From Date
        Range("B" & FiltRow + 1).Value = DataCol + 26 + 3 'To Date
        FiltRow = FiltRow + 3
      GoTo NextCol
    End If
    
      'On Amount Type
    If FiltType = "Amount" Then
    .Range("E" & FiltRow - 1).Value = Sheet2.Cells(3, DataCol).Value
        .Range("AmountSearch").Copy
        .Range("D" & FiltRow).PasteSpecial xlPasteAll
        Range("B" & FiltRow).Value = DataCol + 26 'From Amount
        Range("B" & FiltRow + 1).Value = DataCol + 26 + 3 'To Amount
        FiltRow = FiltRow + 3
      GoTo NextCol
    End If
    
      'On Number Type
    If FiltType = "Number" Then
    .Range("E" & FiltRow - 1).Value = Sheet2.Cells(3, DataCol).Value
        .Range("NumberSearch").Copy
        .Range("D" & FiltRow).PasteSpecial xlPasteAll
        Range("B" & FiltRow).Value = DataCol + 26 'From Number
        Range("B" & FiltRow + 1).Value = DataCol + 26 + 3 'To Number
        FiltRow = FiltRow + 3
      GoTo NextCol
    End If

NextCol:
Next DataCol
.Range("A9").Value = False
End With
ResetCalc
End Sub

Sub RunFilter()
Dim ActRow, DataCol, FirstListRow, LastDataRow, LastListRow, ListItemRow, CriteriaRow, CriteriaCol As Long
Dim LastCriteriaRow1, LastCriteriaRow2, LastResultsRow1, LastResultsRow2, LastResultsRow3 As Long
Dim FoundLast As Range
With Sheet1
.Range("A9").Value = True
.Range("G20:O9999").ClearContents 'Clear Existing Data
'Determine Field Type
ActRow = .Range("A7").Value 'Active Filter Change Row
DataCol = .Range("B" & ActRow).Value

'On Text Change
If .Range("D" & ActRow).Value = "L" Then
    If InStr(.Range("E" & ActRow).Value, ":") <> 0 Or .Range("E" & ActRow).Value = Empty Then Sheet2.Cells(4, DataCol).ClearContents Else: Sheet2.Cells(4, DataCol).Value = "*" & .Range("E" & ActRow).Value & "*"
End If

'On Date, Amount Or Number From/Min
If .Range("D" & ActRow).Value = "From:" Or .Range("D" & ActRow).Value = "Min:" Then
    Sheet2.Cells(4, DataCol).Value = ">=" & .Range("E" & ActRow).Value 'From/Min Value
End If

'On Date, Amount Or Number To/Max
If .Range("D" & ActRow).Value = "To:" Or .Range("D" & ActRow).Value = "Max:" Then
    Sheet2.Cells(4, DataCol).Value = "<=" & .Range("E" & ActRow).Value 'To/Max Value
End If

'Run Advanced Filter 1
    DeleteFilters 'Clear Old Criteria & Extract Named Ranges
    LastDataRow = Sheet2.Range("A9999").End(xlUp).Row  'Determin Last Row of Item Data
    Sheet2.Range("AC4:AK9999").ClearContents 'Clear Any Previous Results
    Sheet2.Range("A3:I" & LastDataRow).AdvancedFilter xlFilterCopy, CriteriaRange:=Sheet2.Range("Q3:Y4"), CopyToRange:=Sheet2.Range("AC3:AK3"), unique:=True
    LastResultsRow1 = Sheet2.Range("AC9999").End(xlUp).Row
    If LastResultsRow1 < 4 Then GoTo NoData
    
'On List Type Change
    If .Range("D" & ActRow).Value = "¨" Or .Range("D" & ActRow).Value = "þ" Then
        FirstListRow = .Range("D8:D" & ActRow).Find("", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
        LastListRow = .Range("D" & ActRow).End(xlDown).Row

        'Set Criteria Row & Column
        If .Range("B" & ActRow).Value = "Type" Then CriteriaCol = 41 Else: CriteriaCol = 57
        Range(Sheet2.Cells(4, CriteriaCol), Sheet2.Cells(999, CriteriaCol)).ClearContents 'Clear Existing Criteria
        CriteriaRow = 4
        
        For ListItemRow = FirstListRow To LastListRow
            If .Range("D" & ListItemRow).Value = "þ" Then
                Sheet2.Cells(CriteriaRow, CriteriaCol).Value = .Range("E" & ListItemRow).Value 'Set Item Criteria
                CriteriaRow = CriteriaRow + 1
            End If
        Next ListItemRow
    End If
    LastCriteriaRow1 = Sheet2.Range("AO999").End(xlUp).Row 'Last Criteria 1 Row
    LastCriteriaRow2 = Sheet2.Range("BE999").End(xlUp).Row 'Last Criteria 2 Row

    'Run Advanced Filter 2
    DeleteFilters 'Clear Old Criteria & Extract Named Ranges
    Sheet2.Range("AC3:AK" & LastResultsRow1).AdvancedFilter xlFilterCopy, CriteriaRange:=Sheet2.Range("AO3:AO" & LastCriteriaRow1), CopyToRange:=Sheet2.Range("AS3:BA3"), unique:=True
    LastResultsRow2 = Sheet2.Range("AS9999").End(xlUp).Row
    If LastResultsRow2 < 4 Then GoTo NoData
    
    'Run Advanced Filter 2
    DeleteFilters 'Clear Old Criteria & Extract Named Ranges
    Sheet2.Range("AS3:BA" & LastResultsRow2).AdvancedFilter xlFilterCopy, CriteriaRange:=Sheet2.Range("BE3:BE" & LastCriteriaRow2), CopyToRange:=Sheet2.Range("BI3:BQ3"), unique:=True
    LastResultsRow3 = Sheet2.Range("BI9999").End(xlUp).Row
    If LastResultsRow3 < 4 Then GoTo NoData
    
    .Range("G20:O" & LastResultsRow3 + 16).Value = Sheet2.Range("BI4:BQ" & LastResultsRow3).Value 'Copy Over Filtered Data

NoData:

.Range("A9").Value = False 'Set Load To false to prevent duplicate runs
.Range("G20").Select 'Select First Item In Table to reload
End With

End Sub

Sub DeleteFilters()
    On Error Resume Next
    Sheet2.Names("Criteria").Delete
    Sheet2.Names("Extract").Delete
    On Error GoTo 0
End Sub

'''NOTE: additional code exists for this project. Review download.