Код VBA для добавления дней из одного столбца в другой

Question

У меня есть следующие столбцы в Excel: Дата документа (все ячейки имеют значения) & Дата начальной утилизации (в столбце есть пробелы).

Каждая дата документа ячейка соответствует Дата начальной утилизации ячейка.

Для любых пробел Начальная ячейка даты утилизации,Я хотел бы установить для них 7 дней с соответствующей Дата документа .(Строго пустые ячейки)

Пример: Дата документа = 10/01/2018.Желаемая дата первоначального удаления = 10/08 / 2018.

Существует ли код для выполнения такого действия?(Кстати, у меня примерно 55 000 строк и 51 столбец).

Большое спасибо!Любые предложения или идеи высоко ценятся!

Answer 1

В этом случае цикл через диапазон немного быстрее.Я предполагаю, что ваши данные включены Sheet1, ваша Дата документа включена Column A и Начальное депонирование включено Column B.

Наконец, вам нужно определить, хотите ли вы, чтобы эти 7 дней включали выходные или нет.Я оставил вам решение для обоих.Вам нужно будет удалить один из операторов действия (в середине цикла)

Option Explicit

Sub BetterCallSaul()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim LRow As Long, iRange As Range, iCell As Range

LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set iRange = ws.Range("B2:B" & LRow)

Application.ScreenUpdating = False
    For Each iCell In iRange
        If iCell = "" Then
            iCell = iCell.Offset(, -1) + 7 'Includes Weekends
            iCell = WorksheetFunction.WorkDay(iCell.Offset(, -1), 7) 'Excludes Weekends
        End If
    Next iCell
Application.ScreenUpdating = True

End Sub

Answer 2

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

Sub ddPlus7()

    Dim dd As Long, didd As Long

    With Worksheets("sheet1")
        'no error control on the next two lines so those header labels better be there
        dd = Application.Match("Document Date", .Rows(1), 0)
        didd = Application.Match("Desired Initial Disposition Date", .Rows(1), 0)

        On Error Resume Next
        With Intersect(.Columns(dd).SpecialCells(xlCellTypeConstants, xlNumbers).EntireRow, _
                       .Columns(didd).SpecialCells(xlCellTypeBlanks).EntireRow, _
                       .Columns(didd))
            .FormulaR1C1 = "=rc[" & dd - didd & "]+7"
        End With
        On Error GoTo 0

    End With

End Sub

Answer 3

Если дата вашего документа указана в столбце А, а вы указали дату первоначального удаления в столбце В, то следующие результаты позволят достичь желаемых результатов:

Sub foo()
Dim ws As Worksheet: Set ws = Sheets("Sheet1")
'declare and set the worksheet you are working with, amend as required
Lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A

For i = 2 To Lastrow
'loop from row 2 to the last row with data
    If ws.Cells(i, "B").Value = "" Then
    'if there is no value in Column B then
        ws.Cells(i, "B").Value = ws.Cells(i, "A").Value + 7
        'add seven days to the date from Column A
    End If
Next i
End Sub