Excel VBA質問箱 IV

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

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


39869 / 76732 ←次へ | 前へ→

【41967】Re:教えてください
回答  Hirofumi  - 06/8/27(日) 11:18 -

引用なし
パスワード
   Keinさんと同じ様な物かも?
Worksheetのイヴェントでは無く、1月分一編に転記します

Option Explicit

Public Sub Sample()

  '元々のデータ列数(A列〜E列)
  Const clngColumns As Long = 5
  '結果出力の先頭位置
  Const cstrTop As String = "A1"
  
  Dim i As Long
  Dim j As Long
  Dim lngRows As Long
  Dim vntMonth As Variant
  Dim rngList As Range
  Dim vntData As Variant
  Dim rngResult As Range
  Dim vntResult As Variant
  Dim strProm As String

  'Listの先頭セル位置を基準とする(「名前」列の列見出しのセル位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")

  '月の入力
  strProm = "転記する月を入力して下さい"
  Do
  'ディフォルトとして表示する月を設定(前月を表示、前月以外なら
  '「Month(Date) - 1」を調整する事
    vntMonth = Month(DateSerial(Year(Date), Month(Date) - 1, 1))
    '転記する月を指定
    vntMonth = Application.InputBox(strProm, "月の入力", vntMonth, , , , , 1)
    If VarType(vntMonth) = vbBoolean Then
      strProm = "マクロがキャンセルされました"
      GoTo Wayout
    Else
      '"1〜12の数値以外の場合
      If vntMonth < 1 Or 12 < vntMonth Then
        Beep
        strProm = "1〜12の数値で入力して下さい"
      Else
        Exit Do
      End If
    End If
  Loop
  
  With rngList
    '行数の取得
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows <= 0 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(1).Resize(lngRows, clngColumns).Value
  End With
  
  '画面更新を停止
  Application.ScreenUpdating = False
  
  '出力用配列を確保
  ReDim vntResult(1 To 4, 1 To 1)
  '仮に結果と元表を同じにして置く
  Set rngResult = rngList
  'データの先頭〜最終まで繰り返し
  For i = 1 To lngRows
    'データを結果配列に転記
    For j = 2 To clngColumns
      vntResult(j - 1, 1) = vntData(i, j)
    Next j
    '出力シートを設定
    GetSheets CStr(vntData(i, 1)), cstrTop, rngResult
    'データを転記
    rngResult.Offset(1, vntMonth).Resize(clngColumns - 1).Value = vntResult
  Next i
  
  'メインシートのクリア
  rngList.Offset(1, 1).Resize(lngRows, clngColumns - 1).ClearContents
    
  strProm = "処理が完了しました"
   
Wayout:

  '画面更新を再開
  Application.ScreenUpdating = True
   
  Set rngList = Nothing
  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Private Sub GetSheets(strName As String, strTop As String, rngResult As Range)
  
  Dim i As Long
  Dim lngRows As Long
  Dim wksMark As Worksheet
  
  'シートの存在確認
  For Each wksMark In Worksheets
    If StrComp(wksMark.Name, strName, vbTextCompare) = 0 Then
      Exit For
    End If
  Next wksMark
  'もし、シートが無いなら
  If wksMark Is Nothing Then
    'シートを追加して、シート名を設定
    Set wksMark = Worksheets.Add(After:=rngResult.Parent)
    wksMark.Name = strName
    With wksMark.Range(strTop)
      '列見出しを出力
      .Offset(, 1).Resize(, 12).Value _
          = Array("1月", "2月", "3月", "4月", "5月", "6月", _
              "7月", "8月", "9月", "10月", "11月", "12月")
      '行見出しを設定
      For i = 1 To 4
        .Offset(i).Value _
            = Choose(i, "体重", "血圧高", "血圧低", "体脂肪率")
      Next i
    End With
  End If
  
  '出力位置を設定
  Set rngResult = wksMark.Range(strTop)
  
  Set wksMark = Nothing
      
End Sub
0 hits

【41958】教えてください 超初心者 06/8/27(日) 1:26 質問
【41959】Re:教えてください Kein 06/8/27(日) 2:16 回答
【41963】Re:教えてください T 06/8/27(日) 10:09 質問
【41965】Re:教えてください かみちゃん 06/8/27(日) 10:36 発言
【41968】Re:教えてください T 06/8/27(日) 11:30 お礼
【41967】Re:教えてください Hirofumi 06/8/27(日) 11:18 回答

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