Code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'****
' Caveats:
' 1) assumes the item rows 15:26 and 28:40 on sheet "DWR" will be blank.
' If not, the data will be overwritten.
' 2) code does not do any formatting, so you may want to add it.
' 3) anything else is also possible
Dim WSFrom As Worksheet
Dim WSTo As Worksheet
Dim dtTarget As Date
Dim FromRange As Range
Dim i As Long, j As Long
Dim LastRow As Long
Dim c As Variant
Dim RowCount As Long
Dim arFrom()
If Target.Address <> "$A$7" Then
Exit Sub
End If
Application.ScreenUpdating = False
Set WSFrom = ActiveWorkbook.Sheets("Cost")
Set WSTo = ActiveWorkbook.Sheets("DWR")
dtTarget = WSTo.Cells(7, 1).Value
RowCount = 0
' Here we are getting the range of the target date in worksheet "Cost".
' If it is not found, we will exit.
With WSFrom
LastRow = .Cells(6, 1).End(xlDown).Row
For i = 6 To LastRow Step 1
If .Cells(i, 1).Value = dtTarget Then
' Then i is the row of the first instance of our target date.
Exit For
End If
Next i
' If i >= the value of LastRow, then we know we have searched
' the entire range, and did not find our target date, so exit.
If i > LastRow Then
MsgBox ("Target date not found")
Exit Sub
End If
For j = i To LastRow Step 1
If .Cells(j, 1).Value <> dtTarget Then
' Then we know we have encountered the first instance of
' a date that is not our target.
j = j - 1
Set FromRange = .Range(.Cells(i, 1), .Cells(j, 1))
Exit For
End If
Next j
End With
' Look for code 50040 first, and gather the values if any
For Each c In FromRange
If c.Offset(0, 2).Value = 50040 Then
ReDim Preserve arFrom(1 To 5, 1 To RowCount + 1)
arFrom(1, RowCount + 1) = c.Offset(0, 1).Value
arFrom(2, RowCount + 1) = c.Offset(0, 4).Value
arFrom(3, RowCount + 1) = c.Offset(0, 5).Value
arFrom(4, RowCount + 1) = c.Offset(0, 6).Value
arFrom(5, RowCount + 1) = c.Offset(0, 10).Value
RowCount = RowCount + 1
End If
Next c
' Populate the values in the form. You may have to do some formatting
' of the target cells in your form here, as the code as it is now does
' not do any formatting.
'**** Notice for array columns 4 and 5, we are shifting the column of the target
' cell one to the right. I don't know if it is my Excel or not, but every time
' I ran it, the down time was populated in the end time field. It may have
' something to do with the time fields, but you may have to tweak this.
With WSTo
For i = 1 To UBound(arFrom) Step 1
If 15 + i - 1 <= 26 Then
On Error Resume Next
.Cells(15 + i - 1, 1).Value = arFrom(1, i)
.Cells(15 + i - 1, 5).Value = arFrom(2, i)
.Cells(15 + i - 1, 6).Value = arFrom(3, i)
.Cells(15 + i - 1, 8).Value = arFrom(4, i) '**** you may need to change 8 to 7 here
.Cells(15 + i - 1, 9).Value = arFrom(5, i) '**** you may need to change 9 to 8 here
Else
Exit For
End If
Next i
End With
' Reset the rowcount, and get the values for code 50000
' The rest is the same.
RowCount = 0
ReDim arFrom(1 To 6, 1 To 1)
For Each c In FromRange
If c.Offset(0, 2).Value = 50000 Then
ReDim Preserve arFrom(1 To 6, 1 To RowCount + 1)
arFrom(1, RowCount + 1) = c.Offset(0, 3).Value
arFrom(2, RowCount + 1) = c.Offset(0, 1).Value
arFrom(3, RowCount + 1) = c.Offset(0, 4).Value
arFrom(4, RowCount + 1) = c.Offset(0, 5).Value
arFrom(5, RowCount + 1) = c.Offset(0, 6).Value
arFrom(6, RowCount + 1) = c.Offset(0, 10).Value
RowCount = RowCount + 1
End If
Next c
With WSTo
For i = 1 To UBound(arFrom) Step 1
If 28 + i - 1 <= 40 Then
On Error Resume Next
.Cells(28 + i - 1, 1).Value = arFrom(1, i)
.Cells(28 + i - 1, 4).Value = arFrom(2, i)
.Cells(28 + i - 1, 7).Value = arFrom(3, i)
.Cells(28 + i - 1, 8).Value = arFrom(4, i)
.Cells(28 + i - 1, 9).Value = arFrom(5, i)
.Cells(28 + i - 1, 10).Value = arFrom(6, i)
Else
Exit For
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Bookmarks