| |
しげ さん 今日は。
>追加で説明させていただきますと
>・プロジェクト毎に転記したい情報は一行目だけで
>・プロジェクトBOOKは各担当者が各自書かれていますので、私は入力方法を変え ることができないのです。
>
>BOOK2,3,4の表と別のシートに2006年○月○日〜2007年○月○日と期間が書かれてあるので、見た目には表の10月が何年の10月かは判断できるのですが、VBAで
>判断させるとなると・・どう書いていったらよいのかに悩んでいます。
BOOK2,3,4の月が日付データで入力されていると、もっと楽にできるのですが。
できないということなので、難儀しました。
下記コードでできますが、各プロジェクトのデータは、BOOK2,3,4のSheet1に入っているものとします。
Bookの数は、Book1〜9まで対応できます。
このコードは、Book1の標準モジュールに、貼り付けて、一度保存してください。
ThisWorkbook.Path を使って、ファイル操作をしているので、BOOK1,2,3,4は、全て同じフォルダに入れてください。
これで一応できます。
Sub test()
Dim r As Range
Dim s As Worksheet
Dim i As Long, 抽出年 As Long
Dim v, vnt, vntM, myArray(1 To 13)
Dim m1 As String, m2 As String
Dim LastRow As Long, LastRow2 As Long, clmn As Long
'
ThisWorkbook.Sheets("Sheet2").Cells.ClearContents
vntM = ThisWorkbook.Sheets("Sheet2").Range("A1:M1").Value
vntM(1, 1) = "プロジェクト"
抽出年 = InputBox("抽出年", "Title", 2006)
For i = 4 To 12: vntM(1, i - 2) = 抽出年 & "/" & i: Next
For i = 1 To 3: vntM(1, i + 10) = (抽出年 + 1) & "/" & i: Next
ThisWorkbook.Sheets("Sheet2").Range("A1:M1").Value = vntM
書式設定 ThisWorkbook.Sheets("Sheet2")
'
With ThisWorkbook.Worksheets("Sheet1")
vnt = .Range("b2", .Cells(65536, 1).End(xlUp)).Value
End With
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 1 To UBound(vnt, 1)
Workbooks.Open ThisWorkbook.Path & "\Book" & (Val(Right(vnt(i, 1), 1)) + 1) & ".XLS"
Set s = Workbooks("Book" & (Val(Right(vnt(i, 1), 1)) + 1)).Sheets("Sheet1")
myArray(1) = vnt(i, 1)
日付処理 s, vnt(i, 2)
書式設定 s
LastRow = s.Cells(65536, 1).End(xlUp).Row
For Each r In s.Range("A1", s.Cells(1, 256).End(xlToLeft))
For clmn = 2 To UBound(vntM, 2)
m1 = Format(vntM(1, clmn), "yyyy/mm")
m2 = Format(r.Value, "yyyy/mm")
If m1 = m2 Then Exit For
Next
If clmn <= UBound(vntM, 2) Then
myArray(clmn) = r.Offset(1).Value
End If
Next
'
With ThisWorkbook.Sheets("Sheet2")
LastRow2 = .Cells(65536, 1).End(xlUp).Row
.Cells(LastRow2 + 1, 1).Resize(1, UBound(vntM, 2)).Value = _
Application.Transpose(Application.Transpose(myArray))
End With
Erase myArray
Workbooks("Book" & (Val(Right(vnt(i, 1), 1)) + 1) & ".XLS").Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'
Set s = Nothing
Erase vntM: Erase myArray
ThisWorkbook.Worksheets("Sheet2").Select
End Sub
Sub 書式設定(ws As Worksheet)
With ws
.Range("C1", .Cells(1, 256).End(xlToLeft)).NumberFormatLocal = "m月"
.Range("B1").NumberFormatLocal = "yyyy/m月"
.Cells(1, 256).End(xlToLeft).NumberFormatLocal = "yyyy/m月"
End With
End Sub
Sub 日付処理(s As Worksheet, dd)
Dim myday, d, myArray()
Dim i As Integer, m As Integer, y As Integer
'
myday = Split(dd, "〜")
y = Year(myday(0))
m = Month(myday(0))
i = 0
Do
d = y & "/" & m ' & "/" & "1"
ReDim Preserve myArray(i)
myArray(i) = d
i = i + 1: m = m + 1
If m > 12 Then m = 1: y = y + 1
Loop Until DateValue(d) >= DateValue(myday(1))
s.Range("A1").Resize(1, UBound(myArray)).Value = myArray
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
