Option Explicit
Const MONROW As Long = 13 '月の行
Const DAYROW As Long = 14 '日の行
Const DATAROW As Long = 16 'データ開始行
Const MONCOL1 As Long = 4 '月の列第一候補
Const MONCOL2 As Long = 7 '月の列第二候補
Dim dicTB As Object 'B列の連想配列 キー:文字列(BOO,CRO等) 値:日(1~月末日)
Dim dicTC As Object 'C列の連想配列 キー:文字列(X12345等) 値:True
Dim ms As Worksheet '外注別手配分シート
Dim yyyy As Long '年(yyyy)
Dim mm As Long '月(mm)
Public Sub 日付設定()
Dim myFile As Variant '選択ファイル
Dim ans As Integer
Dim wb As Workbook '選択ファイル
Dim ws As Worksheet '選択ファイルのシート
Dim maxrowB As Long 'B列最大行
Dim maxrowC As Long 'C列最大行
Dim maxcolK As Long '4行目(日)の仮の最大列
Dim maxcol As Long '4行目(日)の最大列
Dim wrow As Long '行番号
Dim key As String '文字列
Dim wmm As String '月
Dim dd As Long '日
Dim wcol As Long 'カラム番号
Dim moncol As Long '月のカラム番号
Set ms = Worksheets("外注別手配分")
myFile = Application.GetOpenFilename("Excelファイル(*.xls),*.xls")
If myFile = False Then Exit Sub
Set wb = Workbooks.Open(myFile)
Set ws = wb.Worksheets(2)
ws.Activate
ans = MsgBox(myFile & "を読み込みました。" & vbLf & "このファイルを処理しますか", vbOKCancel)
If ans <> vbOK Then
wb.Close
Exit Sub
End If
'月の取得
moncol = MONCOL1
If ws.Cells(MONROW, MONCOL1).Value = "" Then
moncol = MONCOL2
End If
wmm = ws.Cells(MONROW, moncol).Value
mm = 0
If Right(wmm, 1) = "月" Then
wmm = Left(wmm, Len(wmm) - 1)
If IsNumeric(wmm) = True Then
mm = CLng(wmm)
End If
End If
If mm < 1 Or mm > 12 Then
ws.Cells(MONROW, moncol).Select
MsgBox ("月不正1")
Exit Sub
End If
If IsDate(ws.Cells(DAYROW, moncol).Value) = False Then
ws.Cells(DAYROW, moncol).Select
MsgBox ("日不正1")
Exit Sub
End If
If Month(ws.Cells(DAYROW, moncol).Value) <> mm Then
ws.Cells(MONROW, moncol).Select
MsgBox ("月不正2")
Exit Sub
End If
'DAYROW行の仮の最終列を求める
maxcolK = ws.Cells(DAYROW, Columns.count).End(xlToLeft).Column
'DAYROW行の真の最終列を求める
maxcol = maxcolK
For wcol = moncol To maxcolK
If ws.Cells(DAYROW, wcol).Value = "" Then
maxcol = wcol - 1
Exit For
End If
Next
'日の連続性チェック
For wcol = moncol + 1 To maxcol
If ws.Cells(DAYROW, wcol - 1).Value + 1 <> ws.Cells(DAYROW, wcol).Value Then
ws.Cells(DAYROW, wcol).Select
MsgBox ("日不正2")
Exit Sub
End If
Next
Set dicTB = CreateObject("Scripting.Dictionary") ' 連想配列の定義
Set dicTC = CreateObject("Scripting.Dictionary") ' 連想配列の定義
maxrowB = ws.Cells(Rows.count, "B").End(xlUp).Row 'B列の最大行取得
maxrowC = ws.Cells(Rows.count, "C").End(xlUp).Row 'C列の最大行取得
'B列の文字列登録
For wrow = DATAROW To maxrowB
key = ws.Cells(wrow, "B").Value
If key <> "" Then
'同一文字があるならエラー終了
If dicTB.exists(key) = True Then
ws.Cells(wrow, "B").Select
MsgBox (key & ":B列記号 二重登録")
Exit Sub
End If
'その文字列を記憶
dicTB(key) = 0
'開始日~最終列までM,M/Nを検索する
For wcol = moncol To maxcol
'M,M/Nがあれば、その日を記憶し、以降の日付は検索しない
If ws.Cells(wrow, wcol).Value = "M" Or ws.Cells(wrow, wcol).Value = "M/N" Then
dicTB(key) = ws.Cells(DAYROW, wcol).Value
Exit For
End If
Next
End If
Next
'C列の文字列登録
For wrow = DATAROW To maxrowC
key = ws.Cells(wrow, "C").Value
If key <> "" Then
'同一文字列があるならエラー終了
If dicTC.exists(key) = True Then
ws.Cells(wrow, "C").Select
MsgBox (key & ":C列記号 二重登録")
Exit Sub
End If
'その文字列を記憶
dicTC(key) = True
End If
Next
Call set_date("C") 'C列の処理
Call set_date("I") 'I列の処理
wb.Close '選択ファイルクローズ
MsgBox ("完了")
End Sub
'日付設定
Private Sub set_date(ByVal col As String)
Dim maxrow As Long
Dim wrow As Long
Dim val As String
Dim vals As Variant
Dim dd As Date
maxrow = ms.Cells(Rows.count, col).End(xlUp).Row '指定列の最大行取得
'2~最終行まで繰り返す
For wrow = 2 To maxrow
val = ms.Cells(wrow, col).Value
'空白セルはスキップ
If val = "" Then GoTo NEXT99
'-で分割する
vals = Split(val, "-")
'2つ以上に分割されたなら処理
If UBound(vals) >= 1 Then
'1番目の文字列がC列の文字列に一致し、2番目の文字列がB列の文字列に一致するなら
If dicTC.exists(vals(0)) = True And dicTB.exists(vals(1)) = True Then
'M日を取り出す
dd = dicTB(vals(1))
'M日が存在するなら、その日付をL列に設定
If dd <> 0 Then
ms.Cells(wrow, "L").Value = dd
End If
End If
End If
NEXT99:
Next
End Sub