Do you accept a VBA solution ?
gowflow
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
EEExample.xlsm
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
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
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
Title | # Comments | Views | Activity |
---|---|---|---|
Excel file merge 2 cells with line break | 2 | 23 | |
Multiple Userforms from a previously working Template | 29 | 33 | |
Excel split data and output all combinations. | 2 | 22 | |
Delete rows if they are duplicates | 3 | 16 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
12 Experts available now in Live!