Вставка столбца Excel VBA с использованием функции L oop

Question

У меня есть даты в строке 2, и у меня есть следующий код для вставки столбца в зависимости от того, меньше ли дата в B1, чем дата в B2, C2 и т. Д. c ....

Sub Test3()

If DateValue(Cells(1, 2).Value) < DateValue(Cells(2, 2).Value) Then
Range("B2").EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")

ElseIf DateValue(Cells(1, 2).Value) < DateValue(Cells(2, 3).Value) Then
Range("C2").EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")

End If

End Sub

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

Sub DateLoopTest()
Dim i As Integer
i = 1
Do Until DateValue(Cells(1, 2).Value) < DateValue(Cells(2, i + 1).Value)
Cells(2, i + 1).EntireColumn.Select
i = i + 1
Loop
ActiveCell.EntireColumn.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(2, Selection.Column).Select
ActiveCell.Value = Range("B1")

End Sub

Я получаю ошибку во время выполнения '13': Несоответствие типов

Независимо от того, сколько я с этим связываюсь, я не могу его получить на l oop, как я хочу в моем первом примере. Любые предложения

Answer 1

возможно я ошибся, потому что я просто смотрю на ваш код, попробуйте еще раз, надеюсь, это поможет:)

Sub DateLoopTest1()
    Dim i As Integer, isCellhere As Boolean, isExistCell As Boolean, isRecentday As Boolean: i = 0:
    isRecentday = True
    'get lastCell index for Loop
    Dim iLast As Integer: iLast = Cells(2, 15000).End(xlToLeft).Column
    Dim iMax As Integer: iMax = 2            'default
    Dim Cellmax As Range: Set Cellmax = [b2] 'default

    Dim Datedefault As Variant: Datedefault = #1/1/1000#
    If iLast = 1 Then Exit Sub
    'Loop until CellMax
    For i = 0 To iLast - 2
     isCellhere = Datedefault < DateValue(IIf(IsDate([b2].Offset(0, i)), [b2].Offset(0, i), Datedefault))
     'stop if True
     If isCellhere Then Set Cellmax = [b2].Offset(0, i): Datedefault = DateValue([b2].Offset(0, i).Value)
    Next i

    Cellmax.EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Cellmax.Offset(0, -1).Value = [b1]
End Sub

Answer 2

Вы можете обратиться к этому коду:

Sub DateLoopTest()
    Dim i As Integer
    i = 0
    'Loop from [B2] offset 0 to 1,2... -> then stop at [b2].offset(0,i) 
    Do Until (DateValue([b1]) < DateValue(IIf(IsDate([b2].Offset(0, i)), [b2].Offset(0, i), [b1])))
        i = i + 1
    Loop
    [b2].Offset(0, i).EntireColumn.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    [b2].Offset(0, i).Value = [b1]
End Sub