Блог

Я недавно изучаю VBA для MS Excel 2007. Я написал простой цикл, чтобы заполнить недостающие дни недели, следующим образом. Таким образом, одни и те же строки повторяются для каждой пары последовательных дней, только с измененными названиями дней (я опустил здесь все, кроме двух, потому что это стало слишком длинным). Единственное предостережение заключается в том, что я хочу, чтобы «Новое» добавлялось в ячейку справа всякий раз, когда создается новая ячейка со значением «Понедельник». Итак i.range("B2").Value = "New" , для первого блока есть дополнительная строка.

 Sub FillWeek()

For Each i In Selection
    If i.Value = "Sunday" And i.Range("A2") <> "Monday" Then
        i.Range("A2").Insert
        i.Range("A2").Value = "Monday"
        i.Range("B2").Value = "New"
        i.Range("A2").Interior.Color = 192
    End If

Next i
        
For Each i In Selection
    If i.Value = "Monday" And i.Range("A2") <> "Tuesday" Then
        i.Range("A2").Insert
        i.Range("A2").Value = "Tuesday"
        i.Range("A2").Interior.Color = 192
    End If

Next i

#And the code continues for all other consecutive days pairs
 

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

Неожиданные Результаты

1. Почему «Новый» не был добавлен сразу после понедельника, он был добавлен один раз рядом с субботой, а затем он не был добавлен один раз рядом с понедельником?
2. Почему пятница не была добавлена после четверга, а воскресенье не было добавлено после субботы ближе к концу?

Вот один из способов:

 Sub AddDays()
Dim days As Variant
Dim ct As Long
Dim startCell As Range
days = Array("Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday")
On Error Resume Next
Set startCell = Application.InputBox("Select the first cell containing days of the week", "Days of week check", ActiveCell.Address, , , , , 8)
On Error Goto 0
If Not startCell Is Nothing Then
    Do
        If startCell.Offset(ct).Value <> days(ct) Then
            startCell.Offset(ct).EntireRow.Insert
            startCell.Offset(ct).Value = days(ct)
            startCell.Offset(ct, 1).Value = "New"
        Else
            ct = ct   1
        End If
    Loop Until ct >= 7
End If
 

Конец Суб

Попробуйте этот код. Обработка выполняется из активной ячейки. Вы можете начать с любого дня недели. Обрабатывает переменное количество недель

 Sub FillDays()
    Dim dict As New Collection, cl As Range, arr, cur, nxt, mst
    arr = Split("Sunday Monday Tuesday Wednesday Thursday Friday Saturday")
    For cur = 0 To UBound(arr)
        dict.Add cur, arr(cur)       'make the dict name:index, key = name, e.g. "Sunday":0 to get the index by name
    Next
    
    Set cl = ActiveCell   'get the start cell
    Do While True
        cur = cl.Text           'get the text from the current cell
        nxt = cl.Offset(1).Text 'get the text from the next cell
        If cur = "" Or nxt = "" Then Exit Do    'if current cell or next cell is empty then exit loop
        cur = dict(cur)           'get the index of the day of the week from the current cell
        nxt = dict(nxt)           'get the index of the day of the week from the next cell
        mst = (cur   1) Mod 7   'calculate the proper index for the next cell
        If mst <> nxt Then      'if expected weekday <> next weekday
            'add the expected weekday and shift to the next cell
            cl.Offset(1).EntireRow.Insert
            Set cl = cl.Offset(1)
            cl.Value = arr(mst)
            If mst = 1 Then cl.Offset(, 1) = "New"  'a new cell with value "Monday" is created
            cl.Resize(, 2).Font.Bold = True 'debug
        Else    'if expected weekday = next weekday
            Set cl = cl.Offset(1)   'shift to the next cell only
        End If
    Loop
End Sub
 

Изменить 2

Дополнительные функции: не чувствителен к регистру, устойчив к дополнительным пробелам, обрабатывает неправильные названия дней недели

 Sub FillDays()
    Dim dict As New Collection, cl As Range, arr, cur, nxt, mst
    arr = Split(LCase("Sunday Monday Tuesday Wednesday Thursday Friday Saturday"))
    For cur = 0 To UBound(arr)
        dict.Add cur, arr(cur)       'make the dict name:index, key = name, e.g. "Sunday":0 to get the index by name
    Next
    
    Set cl = ActiveCell   'get the start cell
    Do While True
        cur = LCase(Trim(cl.Text))      'get the text from the current cell
        Set cl = cl.Offset(1)           'move to the next cell
        nxt = LCase(Trim(cl.Text))      'get the text from the next cell
        On Error Resume Next
        cur = dict(cur)         'get the index of the day of the week from the current cell
        nxt = dict(nxt)         'get the index of the day of the week from the next cell
        'if the cells do not contain the day of the week or is empty >> exit
        If cur = "" Or nxt = "" Or Err.Number <> 0 Then Exit Do
        On Error GoTo 0
        mst = (cur   1) Mod 7   'calculate the proper index for the next cell
        If mst <> nxt Then      'if expected weekday <> next weekday
            'add the expected weekday and shift to the next cell
            cl.EntireRow.Insert ' side effect: shifts the cl to the next row
            Set cl = cl.Offset(-1)  'compensate for the side effect
            cl.Value = WorksheetFunction.Proper(arr(mst))   'Capitalized name
            If mst = 1 Then cl.Offset(, 1) = "New"  'a new cell with value "Monday" is created
            cl.Resize(, 2).Font.Bold = True 'debug
        End If
    Loop
End Sub
 

Результат редактирования 2