Функция для копирования значений в пустую ячейку на VBA в соответствии с некоторыми условиями

Question

Я новичок ie в мире программирования, и в настоящее время я сталкиваюсь с проблемой в VBA.

Я построил таблицу на месячный календарь, и под номером каждого дня есть пустой пробел должен быть заполнен в зависимости от некоторых условий.

Я хочу заполнить эти пробелы списком имен, в зависимости от того, имеет ли человек значение Active или нет. Другое навязанное условие: если дата календаря является выходным днем, ячейка останется пустым пространством, поэтому я сделал список выходных для проверки этого условия.

Вот код, который я сделал до сих пор:

Sub teste()
line_fill = 5
line_names = 3
column_names = 17
column_active = 18

For i = 6 To 10
    Dim values As Worksheets("Planilha1").Cells(5, i))
    Dim test As Worksheets("Planilha1").Cells(line_fill - 1, i)
    Dim names As Worksheets("Planilha1").Cells(line_names, column_active)
    Dim active As Worksheets("Planilha1").Cells(line_names, column_names)

    If IsEmpty(test) And test.value <> WorksheetFunction.VLookup(test.value, Sheet1.Range("M4:M100"), 1, False) Then
        If names.value = "Ativo" Then
            values = active
    line_names = line_names + 1
    i = i + 1
Next i
End Sub

Изображение электронной таблицы

Ссылка на электронную таблицу, которую я использую

Answer 1

Пожалуйста, попробуйте пройти по коду с помощью F8, чтобы вы поняли, что я сделал, и попытайтесь настроить его под свои нужды.

Это настройка, которую я использовал для кодирования:

И это код:

Option Explicit

Public Sub CopyValuesInCalendar()

    Dim targetSheet As Worksheet
    Dim calendarRange As Range
    Dim holidaysRange As Range
    Dim teamRange As Range
    Dim evalDayCell As Range

    Dim teamFilteredList As Variant

    Dim holidayLastRow As Long
    Dim teamLastRow As Long

    Dim counter As Long

    Set targetSheet = ThisWorkbook.Worksheets("Planilha1")

    targetSheet.AutoFilterMode = False

    Set calendarRange = targetSheet.Range("D4:J13")

    holidayLastRow = targetSheet.Cells(targetSheet.Rows.Count, 12).End(xlUp).Row

    teamLastRow = targetSheet.Cells(targetSheet.Rows.Count, 16).End(xlUp).Row

    Set holidaysRange = targetSheet.Range("L4:N" & holidayLastRow)

    Set teamRange = targetSheet.Range("P3:Q" & teamLastRow)

    teamFilteredList = GetActiveTeamMembers(teamRange)

     For Each evalDayCell In calendarRange.Cells

        If IsNumeric(evalDayCell.Value) And evalDayCell.Value <> vbNullString Then

            If Not IsHoliday(evalDayCell.Value, holidaysRange) Then

                If counter > UBound(teamFilteredList) Then
                    counter = 1
                Else
                    counter = counter + 1
                End If

                evalDayCell.Offset(1, 0).Value = GetTeamMemberName(counter, teamFilteredList)

            End If

        End If

    Next evalDayCell



End Sub

Private Function IsHoliday(ByVal dayNum As Long, ByVal holidayRange As Range) As Boolean

    Dim evalCell As Range

    For Each evalCell In holidayRange.Columns(1).Cells

        If evalCell.Value = dayNum Then

            IsHoliday = True

        End If

    Next evalCell

End Function

Private Function GetActiveTeamMembers(ByVal teamRange As Range) As Variant

    Dim evalCell As Range

    Dim counter As Long
    Dim tempList() As Variant

    For Each evalCell In teamRange.Columns(1).Cells

        If evalCell.Offset(0, 1).Value = "Ativo" Then

            ReDim Preserve tempList(counter)

            tempList(counter) = evalCell.Value

            counter = counter + 1

        End If

    Next evalCell

    GetActiveTeamMembers = tempList

End Function

Private Function GetTeamMemberName(ByVal counter As Long, ByVal teamFilteredList As Variant) As String

    GetTeamMemberName = teamFilteredList(counter - 1)

End Function

Дайте мне знать, если это поможет .