asked on

Lookup Date Ranges In Excel

I would like a formula for column b on sheet 1 in my attached example. I need the formula to look at the value in column A and lookup date ranges on sheet 2 and sheet 3 based on the value in column a on both of those sheets. This program is for employee scheduling. I need to be able to easliy show dates that will be worked on sheet 1 that summarizes sheets 2 and sheets 3.
EEExample.xlsx

Jacques Geday

I would like a formula ....

Do you accept a VBA solution ?

gowflow

portillosjohn

ASKER

Sure if it simple enough for me to implement.

Jacques Geday

Simple yes as long as your 'real workbook' is same in format and in row positions as the one you posted or else then will be running back and forth endlessly to adapt it correctly.

So my suggestion if you feel that the workbook you have is not the same as this one just change the confidential info and then post it.

gowflow

portillosjohn

ASKER

You can use the example and I should be able to adapt it.

Saurabh Singh Teotia

Their you go i wrote a UDF mlook to pick the values from the sheet in the manner you want to do..

Currently i have wrote this UDF to pick from individual worksheets...however if you want to change that to pick from all worksheets in 1 go..let me know...

In additional the way it works is-->

=Mlook(what to lookup,range where you want to look from,This for row number as in from which row you want the answer from, this is for column number i.e. which column has your answer starting from)

Let me know if you need any help on this..

Option Explicit

Function Mlook(r As Range, rng As Range, k As Long, z As Long)

    Dim cell As Range
    Dim lc As Long, ws As Worksheet
    Dim xy As Long, sp As String, lp As String, str As String

    Set ws = Sheets(rng.Parent.Name)



    lc = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column


    ' On Error Resume Next
    If Application.WorksheetFunction.CountIf(rng, r.Value) > 0 Then
        For Each cell In rng
            If cell.Value = r.Value Then

                xy = z

                Do Until xy > lc
                    If ws.Cells(cell.Row, xy).Value <> "" And sp = "" Then
                        sp = Format(ws.Cells(k, xy).Value, "m/d")
                    ElseIf ws.Cells(cell.Row, xy + 1).Value = "" And ws.Cells(cell.Row, xy).Value <> "" And lp = "" Then
                        lp = Format(ws.Cells(k, xy).Value, "m/d")
                        If str = "" Then

                            str = sp & "-" & lp
                            sp = ""
                            lp = ""
                        Else
                            str = str & ", " & sp & "-" & lp
                            sp = ""
                            lp = ""
                        End If
                    End If
                    xy = xy + 1

                Loop


            End If
        Next cell
    Else
        Mlook = "No Match Found"
        Exit Function
    End If

Mlook = str
End Function

Open in new window

EEExample.xlsm

Jacques Geday

ok here is my solution I tried to make it more readable and it is linked to the button Update Schedule in Sheet1 I kept a copy of your original Sheet1 called Sheet1 (2) to compare figures.

here is the code that is in Module1 all you need is to copy this whole Module1 to your production workbook and if you don't want a button just run the macro UpdateSchedules.

Sub UpdateSchedules()
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim MaxRow1 As Long, MaxCol2 As Long, MaxCol3 As Long, I As Long, J As Long
Dim cCell As Range, Rng As Range
Dim sSchedule As String, sFm As String, sTo As String
Dim vRange As Variant

Set WS1 = Sheets("Sheet1")
MaxRow1 = WS1.Range("A" & WS1.Rows.Count).End(xlUp).Row
Set WS2 = Sheets("Sheet2")
MaxCol2 = WS2.Rows(3).End(xlToRight).Column
Set WS3 = Sheets("Sheet3")
MaxCol3 = WS3.Rows(3).End(xlToRight).Column
WS1.Range("B2:B" & MaxRow1).ClearContents

For I = 2 To MaxRow1
    
    '---> Check and gather data from Sheet2
    Set cCell = WS2.Range("A:A").Find(what:=WS1.Cells(I, "A"), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
    If Not cCell Is Nothing Then
        Set Rng = WS2.Range(WS2.Cells(cCell.Row, "C"), WS2.Cells(cCell.Row, MaxCol2)).SpecialCells(xlCellTypeConstants)
        If InStr(1, Rng.Address, ",") <> 0 Then
            vRange = Split(Rng.Address, ",")
            For J = LBound(vRange) To UBound(vRange)
                sFm = Mid(vRange(J), 2, 1)
                sTo = Mid(vRange(J), InStr(1, vRange(J), ":") + 2, 1)
                If sSchedule <> "" Then sSchedule = sSchedule & ", "
                sSchedule = sSchedule & Format(WS2.Cells(3, sFm), "Mmm dd") & " - " & Format(WS2.Cells(3, sTo), "Mmm dd")
            Next J
        Else
            vRange = Rng.Address
            sFm = Mid(vRange, 2, 1)
            sTo = Mid(vRange, InStr(1, vRange, ":") + 2, 1)
            If sSchedule <> "" Then sSchedule = sSchedule & ", "
            sSchedule = sSchedule & Format(WS2.Cells(3, sFm), "Mmm dd") & " - " & Format(WS2.Cells(3, sTo), "Mmm dd")
        End If

    End If
    
    '---> Check and gather data from Sheet3
    Set cCell = WS3.Range("A:A").Find(what:=WS1.Cells(I, "A"), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
    If Not cCell Is Nothing Then
        Set Rng = WS3.Range(WS3.Cells(cCell.Row, "C"), WS3.Cells(cCell.Row, MaxCol3)).SpecialCells(xlCellTypeConstants)
        If InStr(1, Rng.Address, ",") <> 0 Then
            vRange = Split(Rng.Address, ",")
            For J = LBound(vRange) To UBound(vRange)
                sFm = Mid(vRange(J), 2, 1)
                sTo = Mid(vRange(J), InStr(1, vRange(J), ":") + 2, 1)
                If sSchedule <> "" Then sSchedule = sSchedule & ", "
                sSchedule = sSchedule & Format(WS3.Cells(3, sFm), "Mmm dd") & " - " & Format(WS3.Cells(3, sTo), "Mmm dd")
            Next J
        Else
            vRange = Rng.Address
            sFm = Mid(vRange, 2, 1)
            sTo = Mid(vRange, InStr(1, vRange, ":") + 2, 1)
            If sSchedule <> "" Then sSchedule = sSchedule & ", "
            sSchedule = sSchedule & Format(WS3.Cells(3, sFm), "Mmm dd") & " - " & Format(WS3.Cells(3, sTo), "Mmm dd")
        End If

    End If
    
    '---> Apply Results
    WS1.Cells(I, "B") = sSchedule
    
    
    '---> Initialise Variables
    sSchedule = ""
    sFm = ""
    sTo = ""
    vRange = vbEmpty
Next I

WS1.Range("B:B").EntireColumn.AutoFit
MsgBox "Schedules Updated.", vbExclamation
End Sub

Open in new window

All is in the attached workbook.
gowflow
EEExample-V01.xlsm

portillosjohn

ASKER

Goflow this looks great. Is there a way to expand this to 9 tabs instead of the 2 tabs?

Saurabh Singh Teotia

Their you go.. I changed the formula..it will now automatically pick from all the worksheets of your data...

Just apply this formula and it will consolidate from all the worksheets...

Function Mlook(r As Range, rn As Range, k As Long, z As Long)

    Dim cell As Range, rd As String, rng As Range
    Dim lc As Long, ws As Worksheet, ws1 As Worksheet, rk As Range
    Dim xy As Long, sp As String, lp As String, str As String
rd = rn.Address
    Set ws1 = Sheets(r.Parent.Name)

    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ws1.Name Then
            Set rng = ws.Range(rd)



            lc = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column


            ' On Error Resume Next
            If Application.WorksheetFunction.CountIf(rng, r.Value) > 0 Then
                For Each cell In rng
                    If cell.Value = r.Value Then

                        xy = z

                        Do Until xy > lc
                            If ws.Cells(cell.Row, xy).Value <> "" And sp = "" Then
                                sp = Format(ws.Cells(k, xy).Value, "m/d")
                            ElseIf ws.Cells(cell.Row, xy + 1).Value = "" And ws.Cells(cell.Row, xy).Value <> "" And lp = "" Then
                                lp = Format(ws.Cells(k, xy).Value, "m/d")
                                If str = "" Then

                                    str = sp & "-" & lp
                                    sp = ""
                                    lp = ""
                                Else
                                    str = str & ", " & sp & "-" & lp
                                    sp = ""
                                    lp = ""
                                End If
                            End If
                            xy = xy + 1

                        Loop


                    End If
                Next cell
      
            End If
        End If

    Next ws

    Mlook = str
End Function

Open in new window

Saurabh...
EEExample.xlsm

Jacques Geday

Here it is for all the sheets that you want.

Sub UpdateSchedules()
Dim WS As Worksheet
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim WS3 As Worksheet
Dim MaxRow1 As Long, MaxCol As Long, I As Long, J As Long
Dim cCell As Range, Rng As Range
Dim sSchedule As String, sFm As String, sTo As String
Dim vRange As Variant

Set WS1 = Sheets("Sheet1")
MaxRow1 = WS1.Range("A" & WS1.Rows.Count).End(xlUp).Row
WS1.Range("B2:B" & MaxRow1).ClearContents

For I = 2 To MaxRow1
    For Each WS In ActiveWorkbook.Worksheets
        If WS.Name <> "Sheet1" Then
            MaxCol = WS.Rows(3).End(xlToRight).Column
            '---> Check and gather data from seelct sheet
            Set cCell = WS.Range("A:A").Find(what:=WS1.Cells(I, "A"), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
            If Not cCell Is Nothing Then
                Set Rng = WS.Range(WS.Cells(cCell.Row, "C"), WS.Cells(cCell.Row, MaxCol)).SpecialCells(xlCellTypeConstants)
                If InStr(1, Rng.Address, ",") <> 0 Then
                    vRange = Split(Rng.Address, ",")
                    For J = LBound(vRange) To UBound(vRange)
                        sFm = Mid(vRange(J), 2, 1)
                        sTo = Mid(vRange(J), InStr(1, vRange(J), ":") + 2, 1)
                        If sSchedule <> "" Then sSchedule = sSchedule & ", "
                        sSchedule = sSchedule & Format(WS.Cells(3, sFm), "Mmm dd") & " - " & Format(WS.Cells(3, sTo), "Mmm dd")
                    Next J
                Else
                    vRange = Rng.Address
                    sFm = Mid(vRange, 2, 1)
                    sTo = Mid(vRange, InStr(1, vRange, ":") + 2, 1)
                    If sSchedule <> "" Then sSchedule = sSchedule & ", "
                    sSchedule = sSchedule & Format(WS.Cells(3, sFm), "Mmm dd") & " - " & Format(WS.Cells(3, sTo), "Mmm dd")
                End If
            End If
        End If
    Next WS
    
    
    '---> Apply Results
    WS1.Cells(I, "B") = sSchedule
    
    
    '---> Initialise Variables
    sSchedule = ""
    sFm = ""
    sTo = ""
    vRange = vbEmpty
Next I

WS1.Range("B:B").EntireColumn.AutoFit
MsgBox "Schedules Updated.", vbExclamation
End Sub

Open in new window

File attached.
gowflow
EEExample-V02.xlsm

portillosjohn

ASKER

Awsome gowflow. Last question. Is there a out if a tab is blank or not filled out yet. For "Rng" is nothing?

Jacques Geday

Actually the out is the line before Rng and is the test on cCell is nothing this is the out.

But

I tested it with a blank sheet and with a sheet that had only the header and results are fine no error.

Did you get an error ? if yes then what did you have that generated the error and which one ?

gowflow

Saurabh Singh Teotia

By any chance did you got an opportunity to look at the file which i uploaded..As it gives you the same result by just applying the formula...

Again it will collate data from all of your worksheets into one no matter how many you add..

portillosjohn

ASKER

I It looks like we get an error if the manager column is filled out but no shifts are scheduled.

ASKER CERTIFIED SOLUTION

Jacques Geday

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

portillosjohn

ASKER

Perfect.