Copy the code below into a standard module. The call it with a commandbutton.
Hope this helps! If so, click "YES" below.
Option Explicit
Sub OrganizeMarkets()
Dim rngEurUsed As Range
Dim rngEuriBor As Range
Dim rngDow As Range
Dim colRanges As Collection
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim rngMaster As Range
Dim rng As Range
Dim r1 As Range
Dim r2 As Range
Dim r3 As Range
Dim i As Long
' set date ranges
With Sheets("Sheet1")
Set rngEurUsed = .Range("A3:A" & .Cells(Rows.Count,
"A").End(xlUp).Row)
Set rngEuriBor = .Range("C3:C" & .Cells(Rows.Count,
"C").End(xlUp).Row)
Set rngDow = .Range("E3:E" & .Cells(Rows.Count, "E").End(xlUp).Row)
End With
Set colRanges = New Collection
With colRanges
.Add rngEurUsed
.Add rngEuriBor
.Add rngDow
End With
With Sheets("Sheet2")
' make master date range in sheet2
lngFirstRow = 2
lngLastRow = 1
For Each rng In colRanges
lngLastRow = lngLastRow + rng.Rows.Count
.Range(.Cells(lngFirstRow, "A"), .Cells(lngLastRow, "A")).Value
= rng.Value
lngFirstRow = lngLastRow + 1
Next rng
' remove duplicates from master date range
Set rngMaster = .Range("A2:A" & .Cells(Rows.Count, "A")..End(xlUp).Row)
rngMaster.AdvancedFilter xlFilterInPlace, Unique:=True
End With
' scan for dates in EurUsed range and match with other ranges
For Each rng In rngMaster
' ensure it is a date
If IsDate(rng.Value) Then
' find date in rngEuriBor
Set r1 = rngEurUsed.Find(What:=rng.Text, _
After:=rngEurUsed.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, _
SearchFormat:=False)
' if date is found, find date in rngEuriBor
If Not r1 Is Nothing Then
Set r2 = rngEuriBor.Find(What:=rng.Text, _
After:=rngEuriBor.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, _
SearchFormat:=False)
End If
' if date is found, find date in rngDow
If Not r2 Is Nothing Then
Set r3 = rngDow.Find(What:=rng.Text, _
After:=rngDow.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True, _
SearchFormat:=False)
End If
' if date is found, paste values in master list
If Not r1 Is Nothing And Not r2 Is Nothing And Not r3 Is Nothing
Then
With rng
.Offset(0, 1).Value = r1.Offset(0, 1).Value ' EurUsed
value
.Offset(0, 2).Value = r2.Offset(0, 1).Value ' EuriBor
value
.Offset(0, 3).Value = r3.Offset(0, 1).Value ' Dow value
End With
End If
End If
Next rng
' remove all empty rows
With Sheets("Sheet2")
For i = lngFirstRow To lngLastRow Step -1
If IsEmpty(.Cells(i, "B")) Then
.Rows(i).Delete Shift:=xlUp
End If
Next i
End With
End Sub
