[Tasos]

Καλησπέρα Σταύρο!

Δες ένα παραδειγματικό κώδικα:

Option Explicit

Sub FillPlanTable()
    Dim rngSourceDates As Range
    Dim rngTargetDates As Range
    Dim rngRooms As Range
    Dim c As Range
    Dim d As Range
    Dim f As Range
    Dim FirstAddress As String
    Dim iCol As Integer
    Dim iRow As Integer

    Set rngSourceDates = Worksheets(1).Range("A:A")
    Set rngRooms = Range("C1:N1")
    On Error GoTo ErrH
    Set rngTargetDates = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = True
    With rngRooms
        .Offset(1).Resize(rngTargetDates.Count, .Count).Replace _
                What:=ChrW(922), Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False

        .Offset(1).Resize(rngTargetDates.Count, .Count).Replace _
                What:="K", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False
    End With
    For Each c In rngTargetDates
        If Not IsEmpty(c) And IsDate(c) Then
            Set f = rngSourceDates.Find(c)
            If Not f Is Nothing Then
                FirstAddress = f.Address
                Do
                    Set d = rngRooms.Find(What:=f.Offset(, 1), LookIn:=xlValues)
                    If Not d Is Nothing Then
                        iRow = c.Row
                        iCol = d.Column
                        Cells(iRow, iCol) = "K"
                    End If
                    Set f = rngSourceDates.Find(What:=c, After:=f)
                    If f Is Nothing Then Exit Do
                Loop While f.Address <> FirstAddress
            End If
        End If
    Next
ErrH:
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    If Err Then MsgBox Err & vbLf & Err.Description, vbExclamation
End Sub

Δες και το συνημμένο παράδειγμα παρακάτω.


Καλή συνέχεια!

Φιλικά

Τάσος