| |
▼ウッシ さん：
毎度丁寧にアドレスいいただきありがとうございます。
最初の行でActiveSheetをPrtSheetというワークシートオブジェクトに代入し、以降使用を止めました。
その上で書き込んで頂いたコードを試しましたが、xlRangeのアドレス、加算セルのアドレス共に意図した通りのアドレスが表示されることを確認いたしました。
念のため書き直したコード全てを下記に記載します。
Dim PrtSheet As Worksheet
Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim xlSheet As Worksheet
Dim yer As String
Dim mon As String
Dim item(4) As Object
Dim i As Long
i = 1
Dim objx As Object
Dim objy As Object
Dim WMon As Long
Dim WItem As Long
'PrtSheetには受注明細を記載したシートがセットされます。
Set PrtSheet = ActiveSheet
PrtSheet.PageSetup.BlackAndWhite = True
'受注明細を記載したシートのタブの色が赤の時のみ実行されるようにしています。
If PrtSheet.Tab.ColorIndex = 3 Then
'xlSheetには1つ目のファイルの出荷履歴のシートがセットされます。
Set xlSheet = ThisWorkbook.Worksheets("商品マスター")
With PrtSheet
'yerには受注明細シートに記載されている納入年を、monには納入月が代入されます。それらの変数を使用し、出荷数を記入すべき出荷履歴シートのX軸を検索します。
yer = Year(.Range("B5"))
mon = Month(.Range("B5"))
Set objx = xlSheet.Cells.Find(What:=DateValue(yer & "/" & mon & "/1"), SearchOrder:=xlByRows, LookIn:=xlFormulas)
'itemには製品コードが入ります。受注明細には最大4製品の売上まで1つのシートに記入できるので、item(4)まで有ります。それらの変数を使用し、出荷数を記入すべき出荷履歴シートのY軸を検索します。
Set item(1) = .Range("B9")
Set item(2) = .Range("B14")
Set item(3) = .Range("B19")
Set item(4) = .Range("B24")
Do Until item(i) = ""
Set objy = xlSheet.Cells.Find(What:=item(i), SearchOrder:=xlByColumns)
'検索されたX軸、Y軸の行、列の情報をそれぞれWMonとWItemに代入します
WMon = objx.Column
WItem = objy.Row
'出荷数量、コメント書き込みのプロージャーを呼び出します。
Call WComment(xlSheet, WItem, WMon, item(), i)
'2つ目のファイルに記入するプロージャーを呼び出します
Call Standard(mon, item(), i)
i = i + 1
Loop
'受注明細に印刷日時を記入し、タブの色をオレンジに変更します。
.Range("I2") = Date
.Tab.ColorIndex = 7
End With
ThisWorkbook.Activate
End If
End Sub
'----------------------------------------------------------------------------
Sub Standard(mon As String, item() As Object, i As Long)
Dim xlSheet As Worksheet
Dim objx As Object
Dim objy As Object
Dim WMon As Long
Dim WItem As Long
'Function IsBookOpenを使用し、既にファイルが開いているかを確認し、ファイルを開きます。
If IsBookOpen("RFMラドル出荷状況一覧.xlsx") = False Then
Workbooks.Open Filename:="C:\Users\Yusuke Kumano\Dropbox\RFMラドル出荷状況一覧.xlsx"
End If
With PrtSheet
'xlSheetに主要な製品の在庫数を記載したシートをセットします。
Set xlSheet = Workbooks("RFMラドル出荷状況一覧.xlsx").Worksheets("標準品在庫")
'objxにコメントを書き込むX軸(売上月)の位置を検索します。
'objyにコメントを書き込むY軸(製品)の位置を検索します。
Set objx = xlSheet.Cells.Find(mon & "月", SearchOrder:=xlByRows, LookAt:=xlWhole)
Set objy = xlSheet.Cells.Find(item(i), SearchOrder:=xlByColumns, LookAt:=xlWhole)
'主要な製品ではければ、Subを抜けます。
If objy Is Nothing Then
Exit Sub
End If
'WMonに出荷数量とコメントを書き込む列を、WItemに行をいれます。
WMon = objx.Column + 1
WItem = objy.Row
'出荷数量、コメント書き込みのプロージャーを再度呼び出します。
Call WComment(xlSheet, WItem, WMon, item(), i)
End With
End Sub
'----------------------------------------------------------------------------
Function IsBookOpen(strBookName As String) As Boolean
Dim objBook As Workbook
IsBookOpen = False
For Each objBook In Workbooks
If objBook.Name = strBookName Then
IsBookOpen = True
Exit For
End If
Next
End Function
'----------------------------------------------------------------------------
Sub WComment(xlSheet As Worksheet, WItem As Long, WMon As Long, item() As Object, i As Long)
Dim xlRange As Range
Dim ComTxt As String
'PrtSheetは1つ目のファイルにある売上詳細を記入したワークシートです。
With PrtSheet
'xlSheetは出荷履歴(在庫数)をまとめたシートがセットされています。WMonは出荷月、WItemは売上製品です。
Set xlRange = xlSheet.Cells(WItem, WMon)
MsgBox "xlRangeのアドレスは-----" & xlRange.Address(0, 0, xlA1, True)
MsgBox "加算セルのアドレスは-----" & .Range("F" & item(i).Row).Address(0, 0, xlA1, True)
'xlRangeに既に数字(出荷数)が記入されている場合、加算します。
xlRange.Value = .Range("F" & item(i).Row).Value + xlRange.Value
'ComTxt(コメント内容)はPrtSheet(売上明細シート)に記載されている日付:.Range("D5")、客先:.Range("D5")、出荷数:.Range("F" & item(i).Row)を記載します。
ComTxt = .Range("B5") & " " & .Range("D5") & " " & .Range("F" & item(i).Row).Value & "PC"
'コメントが既にあるかないかで新規記入か追記かを判断しています。
If xlRange.Comment Is Nothing Then
xlRange.AddComment Text:=ComTxt
Else
xlRange.Comment.Text Text:=xlRange.Comment.Text & vbCrLf & ComTxt
End If
'コメント欄のサイズを自動調整します。ここでエラー発生(2回めのみ)。
xlRange.Comment.Shape.TextFrame.AutoSize = True
End With
End Sub
以上、よろしくお願いします。
|
|
くまさん
- 15/10/21(水) 16:18 -
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
