VBA技术问询：基于日期列定位动态插入列并按条件填充值

Let's fix your code step by step, focusing on calculating the correct column offset and improving overall reliability:

Key Insight #

The newly inserted column sits one column to the right of the date column you found (Yesterday). To calculate the offset from column A to this new column:

• Column A is column number 1
• New column number = Yesterday.Column + 1
• Offset value = New column number - 1 = Yesterday.Column

This gives you the exact number of columns to shift right from column A to reach the new column.

Corrected Code #

Sub UpdateOrangeColumn()
    Dim myDate As Date
    Dim Yesterday As Range
    Dim ws As Worksheet
    Dim fruitRange As Range
    Dim cell As Range
    
    ' Set the target worksheet (replace with your sheet name if needed)
    Set ws = ActiveSheet
    
    ' Get date input from user, with error handling for cancellation
    On Error Resume Next
    myDate = Application.InputBox("Please enter the date (DD/MM/YY)", Type:=1)
    On Error GoTo 0
    If IsEmpty(myDate) Then Exit Sub
    
    ' Find the target date in row 1
    Set Yesterday = ws.Rows(1).Find(What:=myDate, _
                                    LookIn:=xlFormulas, _
                                    LookAt:=xlPart, _
                                    SearchOrder:=xlByRows, _
                                    SearchDirection:=xlNext, _
                                    MatchCase:=False)
    
    ' Check if the date was found
    If Yesterday Is Nothing Then
        MsgBox "Date not found in row 1!", vbExclamation
        Exit Sub
    End If
    
    ' Insert new column to the right of the date column
    Yesterday.EntireColumn.Offset(0, 1).Insert Shift:=xlToRight
    
    ' Get only the used fruit names in column A (skip header row)
    Set fruitRange = ws.Range("A1").CurrentRegion.Columns(1).Offset(1, 0)
    
    ' Loop through fruits and update the new column
    For Each cell In fruitRange
        If Left(cell.Value, 4) = "Oran" Then
            ' Use Yesterday.Column as the offset value
            cell.Offset(0, Yesterday.Column).Value = 1
        End If
    Next cell
End Sub

Key Improvements #

• Removed Select/Activate: Using object variables is more efficient and avoids issues with active cell changes.
• Error Handling: Added checks for user cancellation and missing dates to prevent crashes.
• Targeted Range: Instead of looping through the entire column A, we only process rows in your defined data region (A2:A10).
• Clear Offset Logic: Directly uses the found date's column number to calculate the correct shift to the new column.

内容的提问来源于stack exchange，提问作者Gandalfrandalf