| |
少し書きなおしてコメントを入れて置きました
なお、前は範囲をCopyして張りつけていたのですが
今回、範囲の値を代入しています
また、前回のエラーは私のボケで、lngRowの値が決まる前に使用していました
目的は、範囲をクリアする事です
それと、前回、実行ファイルのBookに記述しなさいと書きましたが
月報フォーマットのBookに同様に書いても動くと思います
書き直したコードを記述します
ThisWorkbookのコードモジュールに以下を記述して下さい
Private Sub Workbook_Open()
Dim i As Long
With Worksheets("Sheet1").ComboBox1
For i = 0 To 23
.AddItem i & "時"
Next i
End With
End Sub
Sheet1のコードモジュールに以下を記述して下さい
Private Sub CommandButton1_Click()
With Me.ComboBox1
If .ListIndex <> -1 Then
DataCopy Val(.Value)
End If
End With
End Sub
標準モジュールに以下を記述して下さい
Option Explicit
Public Sub DataCopy(ByVal lngTime As Long)
Const strBookName As String = "月報ﾌｫｰﾏｯﾄ.xls"
Const strResult As String = "月報"
Dim blnExists As Boolean
Dim wkbData As Workbook
Dim wksDaTa As Worksheet
Dim wksResult As Worksheet
Dim lngRow As Long
'"月報ﾌｫｰﾏｯﾄ.xls"がOpenされているか確認
'Workbooksコレクションの全てを繰り返す
For Each wkbData In Workbooks
'コレクションの要素の名前が、"月報ﾌｫｰﾏｯﾄ.xls"なら
If wkbData.Name = strBookName Then
'存在フラグをTrueに
blnExists = True
Exit For
End If
Next wkbData
'Openされていない場合
If Not blnExists Then
Beep
MsgBox "月報ﾌｫｰﾏｯﾄ.xlsがOpenされていません"
Exit Sub
End If
'指定された時間の行位置を取得
lngTime = lngTime + 4
'"月報ﾌｫｰﾏｯﾄ.xls"に就いて
With Workbooks(strBookName)
'アクティブに
.Activate
'"月報"シートの参照を設定
Set wksResult = .Worksheets(strResult)
'"月報"シートのB9:R39をクリア
wksResult.Cells(9, _
"B").Resize(31, 17).ClearContents
'WorkSheetsコレクションの全てを繰り返す
For Each wksDaTa In .Worksheets
'コレクションの要素の就いて
With wksDaTa
'シート名が"月報"で無いなら
If .Name <> strResult Then
'シート名の右二文字を取り出して数値に変換
'日付を取り出す
lngRow = Val(Right(.Name, 2))
'取り出した日付が日付で有るなら
If lngRow > 0 Then
'日付を行位置に変換
lngRow = lngRow + 9 - 1
'時間の有る行位置の範囲の値を
'日付の有る行位置の範囲に代入
wksResult.Cells(lngRow, "B").Resize(, 17).Value _
= .Cells(lngTime, "B").Resize(, 17).Value
End If
End If
End With
Next wksDaTa
End With
Set wksResult = Nothing
Set wksDaTa = Nothing
Set wkbData = Nothing
Beep
MsgBox "処理が完了しました"
End Sub
|
|
Hirofumi
- 04/6/2(水) 21:11 -
