| |
Keinさんと同じ様な物かも？
Worksheetのイヴェントでは無く、１月分一編に転記します
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("１月", "２月", "３月", "４月", "５月", "６月", _
"７月", "８月", "９月", "１０月", "１１月", "１２月")
'行見出しを設定
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
