| |
こんにちは。
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=27135;id=excel
こちらの質問とかなり似ているというか、ほとんど同じですね。
同じ会社の方ですか？
そちらの質問の方で進展があれば書き込もうと思っていたコードですが、
その後まだ反応がないので、こちらに書き込みます。
Private Sub Worksheet_Change(ByVal Target As Range)
Const CNum As Integer = 4
Dim aCell As Range, Rng As Range, fstAdr As String
Dim DateCols() As Long, n As Long
ReDim DateCols(1 To 256)
n = 0
Set aCell = Cells.Find("結果", after:=Cells(Cells.Count))
If aCell Is Nothing Then Exit Sub
fstAdr = aCell.Address
Do
n = n + 1
DateCols(n) = aCell.Column + 1
If Rng Is Nothing Then
Set Rng = aCell.Offset(, 2).Resize(, CNum).EntireColumn
Else
Set Rng = Union(Rng, aCell.Offset(, 2).Resize(, CNum).EntireColumn)
End If
Set aCell = Cells.FindNext(aCell)
Loop Until aCell.Address = fstAdr
Set Target = Intersect(Target, Rng, Me.UsedRange)
If Target Is Nothing Then Exit Sub
ReDim Preserve DateCols(1 To n)
With Application
.EnableEvents = False
.ScreenUpdating = False
.EnableCancelKey = xlErrorHandler
' .Interactive = False
End With
On Error GoTo Err_Handler
For Each aCell In Target
n = WorksheetFunction.Match(aCell.Column, DateCols, 1)
With aCell.EntireRow
If WorksheetFunction.CountBlank(.Cells(1, DateCols(n) + 1).Resize(, CNum)) = CNum Then
.Cells(1, DateCols(n)).ClearContents
Else
.Cells(1, DateCols(n)).Value = Date
End If
End With
Next
On Error GoTo 0
Terminate:
With Application
.EnableEvents = True
.ScreenUpdating = True
.EnableCancelKey = xlInterrupt
' .Interactive = True
End With
Exit Sub
'------------エラーハンドラ------------
Err_Handler:
MsgBox Err.Description
Resume Terminate
End Sub
|
|
でれすけ
- 05/8/5(金) 12:59 -
