Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


40699 / 76732 ←次へ | 前へ→

【41125】Re:検索について
回答  kobasan  - 06/7/31(月) 14:00 -

引用なし
パスワード
   しげ さん 今日は。

>追加で説明させていただきますと
>・プロジェクト毎に転記したい情報は一行目だけで
>・プロジェクト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

0 hits

【41092】検索について しげ 06/7/28(金) 22:20 質問
【41118】Re:検索について kobasan 06/7/30(日) 22:40 発言
【41119】Re:検索について しげ 06/7/31(月) 0:02 発言
【41122】Re:検索について ハチ 06/7/31(月) 8:36 発言
【41127】Re:検索について ハチ 06/7/31(月) 14:32 発言
【41150】Re:検索について しげ 06/7/31(月) 22:40 お礼
【41153】Re:検索について ハチ 06/7/31(月) 23:52 発言
【41321】Re:検索について しげ 06/8/4(金) 23:27 発言
【41322】Re:検索について ハチ 06/8/5(土) 7:31 回答
【41337】Re:検索について しげ 06/8/6(日) 18:02 発言
【41424】Re:検索について しげ 06/8/9(水) 22:02 お礼
【41125】Re:検索について kobasan 06/7/31(月) 14:00 回答
【41151】Re:検索について しげ 06/7/31(月) 22:50 お礼

40699 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free