| |
▼fuji さん：
あまりきれいではありませんが、こんなものかなと作ってみました。
よろしければ確認してみて下さい。
Option Explicit
Sub test()
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim R1 As Long, C1 As Long
Dim Sagyou As Variant, check As Variant
Dim WS1 As Worksheet, WS2 As Worksheet
Set WS1 = ThisWorkbook.Worksheets("Sheet1")
Set WS2 = ThisWorkbook.Worksheets("Sheet2")
m = 3 'データ開始行
n = WS1.Cells(m, 1).End(xlDown).Row 'データ最終行
'作業予定日がある列を確認
k = 0
ReDim Sagyou(1 To 1)
For j = 2 To WS1.Range("B2").End(xlToRight).Column
If WS1.Cells(2, j).Value = "作業予定日" Then
k = k + 1
ReDim Preserve Sagyou(1 To k)
Sagyou(k) = j
End If
Next j
C1 = k
'名簿がある業を確認
R1 = n - m + 2
ReDim check(1 To R1, 1 To C1)
For j = 1 To C1
check(1, j) = WS1.Cells(1, Sagyou(j)).Value
For i = m To n
If WS1.Cells(i, Sagyou(j) + 1).Value = "" Then
If WS1.Cells(i, Sagyou(j)).Value < Date Then
check(i - m + 2, j) = WS1.Cells(i, 1).Value
End If
End If
Next i
Next j
WS2.Range("B1").Resize(R1, C1) = check
Set WS1 = Nothing
Set WS2 = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
