■WorkSheet.Copy時のイベント

#危うく３月は記事０になるとこでした XD

大した話ではないのですが、最近関わったQ&Aで
『ワークシートのコピーをきっかけに、マクロを実行したい』というのがありました。
ぇ？そんなオチ？って終わり方でしたけどちょっと反省点もあり、書いておきます。

Book内で新規Sheetを追加した時にマクロを走らせるには、ThisWorkbookモジュールのWorkbook_NewSheetイベントがあります。
ではBook内で既存Sheetをコピーした時のイベントを捉まえるにはどうしたらいいか。
WorkSheet.Copy時にはWorkbook_NewSheetイベントは発生しませんから、代替的にWorkbook_SheetActivateを使ったりします。
一応回答コードはこれ▼

'ThisWorkbook Module
Option Explicit
Dim flg　　 As Boolean
Dim shCount As Long
Dim shName　As String
'-------------------------------------------------
Private Sub Workbook_NewSheet(ByVal Sh As Object)
　　flg = True
End Sub
'-------------------------------------------------
Private Sub Workbook_Open()
　　shCount = Sheets.Count
End Sub
'-------------------------------------------------
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
　　Dim n As Long

　　n = Sheets.Count
　　If n <> shCount Then
　　　　If n > shCount Then
　　　　　　shName = Sh.Name
　　　　　　Application.OnTime Now, Me.CodeName & ".test"
　　　　End If
　　　　shCount = n
　　End If
End Sub
'-------------------------------------------------
Private Sub test()
　　If flg Then
　　　　flg = False
　　Else
　　　　MsgBox shName
　　End If
End Sub

質問では言及されてませんでしたが、あくまでコピーの時だけの話で、新規シート追加は除外したい場合を考えてみました。
Bookを開いてSheetを切り替えないままコピーしたりするケースを考えると、Workbook_Openイベントでモジュール変数にシート数をセットしておいたほうが良いような気がしますし、
新規追加時にもシート名のお尻に『(数値)』が付加されるケースを考えると、Activeになったシート名で判断するのも使えないし、
...などなど。
少し考え過ぎですね（反省）



コードの流れとしては、「シートコピー時にはWorkbook_SheetActivateイベントのみが発生し、追加時にはWorkbook_SheetActivateイベントの後にWorkbook_NewSheetイベントも発生する」
ので、これを利用する為にApplication.OnTimeメソッドを使ってます。

Workbook_SheetActivate
　▼
Workbook_NewSheet
　▼
OnTimeメソッドで呼び出したプロシージャ

こんな順番で実行されるようにして、途中のWorkbook_NewSheetイベントで、新規シート追加かどうかを判定するわけです。
でもまぁ、こんなややこしい事しなくても、普通はシートコピーしたらお尻に『( )』が付加されますからシート名で判定してもそれほど困らないとは思いますけどね。

ちなみに、
>新規追加時にもシート名のお尻に『(数値)』が付加されるケース
って普通は無いのですが、たまたま私の環境がそうだったりします。
新規Bookや新規Sheetを雛形のシートから作成されるような環境にしてると、そうなる事があります。
C:\Documents and Settings\（ユーザー名）\Application Data\Microsoft\Excel\XLSTART
や
C:\Program Files\Microsoft Office\Office？\XLSTART
などのスタートアップパスに Book.xlt や Sheet.xlt のテンプレートを置く事で設定できます。[win2000/xl2000]

ただ、新規シート追加時に常に『()』が付加されるわけでは無いようで、再現条件が今いち不明です。
検証不足は否めません。
もしかしたら私の環境が壊れかけてる（とは思いたくないですが）のかも -"-

■AutoFilter FilterModeでのFillRightメソッド

知らなかったのは私だけかもしれませんが、FillRight メソッドを使えば
AutoFilter 抽出後の可視セルデータを --＞ 同状態の可視セルのみへ コピーができるのですね。
FillRight メソッドなのでコピー先は限定されますが。

▼サンプルシートを作るマクロ

Sub sample()
　　With Sheets.Add
　　　　.Range("A1:C1").Value = [{"f1","f2","f3"}]
　　　　With .Range("B2:C10")
　　　　　　.Formula = "=int(rand()*10)"
　　　　　　.Value = .Value
　　　　End With
　　　　.Range("4:4,7:7").ClearContents
　　　　.Range("A4,A7,A11:A12").Value = 1
　　　　.Range("B4,B7,B11").Select
　　　　SendKeys "~"
　　　　Application.CommandBars.FindControl(ID:=226).Execute
　　　　.Range("B12").Value = "end"
　　　　.Range("A1").Select
　　　　.Range("A1").CurrentRegion.AutoFilter Field:=1, Criteria1:=1
　　　　.Range("B2:B12").Interior.Color = vbYellow
　　　　.ShowAllData
　　End With
End Sub

▼こんなデータができます。



▼以下、手作業です。 A列 1 でフィルタ抽出し、B列を選択します。



▼右下コーナーにカーソルを合わせて右にフィルドラッグします。



▼右へコピーされます。



▼オートフィルタを解除してみると、ちゃんと可視セルにだけコピーされています。



（確認環境は[win2000/xl2000][winXP/xl2003]）


ついでですが、上記動作をマクロ記録してみると

Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2009/2/4　ユーザー名 : no name
'

'
　　Selection.AutoFilter Field:=1, Criteria1:="1"
　　Range("B4:B12").Select
　　Selection.FillRight
End Sub

これをそのまま実行しても何も起きません。

Range("B4:C12").Select

と、Select範囲を変えれば機能します。
つまり、手動操作と同じ結果を記録マクロで得るなら B4:C12セルを選択して[ Ctrl ]キー+[ r ]キー同時押し。
...のほうが良さそうです。

もうちょっと使えそうな感じで書いてみると以下。

Sub test()
　　With ActiveSheet
　　　　If .AutoFilterMode And .FilterMode Then
　　　　　　With .AutoFilter.Range.Columns(2)
　　　　　　　　If WorksheetFunction.Subtotal(3, .Cells) > 1 Then
　　　　　　　　　　Intersect(.Cells, .Offset(1)).Resize(, 2).FillRight
　　　　　　　　End If
　　　　　　End With
　　　　End If
　　End With
End Sub

（2009.02.05追記）
...微妙に勘違いしてるような？

上記の手動操作の例が悪いですね。
最初から
>B4:C12セルを選択して[ Ctrl ]キー+[ r ]キー同時押し。
の例にしておけば良かったです。
同じフィルドラッグ操作でも、 FilterMode によって実行されるメソッドが違うのでした。
単純に、『オートフィルタ抽出状態での[右方向へのコピー]は可視セルだけが対象になる。』という話な...だけ？

#どうも充電が足りなかったようです XD

■おまじないの話。

（更新途切れてますが、もーネタないですorz）


例えば Worksheet 上に Image コントロールを配置して
複数 Pictures を Loop で読み込みながら印刷したりする場合。
#あくまで例です。そのまま Picture を配置して印刷すればいいじゃんなんてツッコミは無しで XD

Sub pre()
　　ActiveSheet.OLEObjects.Add ClassType:="Forms.Image.1", _
　　　　　　　　　　　　　　　 Left:=0, _
　　　　　　　　　　　　　　　 Top:=0, _
　　　　　　　　　　　　　　　 Width:=300, _
　　　　　　　　　　　　　　　 Height:=200
End Sub

上ので Image 配置。
下ので印刷（プレビュー）です。

Sub try()
　　Dim im As MSForms.Image
　　Dim fiLes, f

　　fiLes = Application.GetOpenFilename("jpgFiLes,*.jpg", , , , True)
　　If VarType(fiLes) = vbBoolean Then Exit Sub
　　With ActiveSheet
　　　　Set im = .Image1
　　　　im.PictureSizeMode = fmPictureSizeModeStretch
　　　　For Each f In fiLes
　　　　　　im.Picture = LoadPicture(f)
　　　　　　.PrintPreview
　　　　Next
　　End With
　　Set im = Nothing
End Sub

ところが望みの結果になりません。
fiLes 数ぶん Loop しただけで、画像が変わりません。
try が終了した後に最後の画像に切り替わります。
要は、描画が追いついていないのでしょう。
こういう場合は[DoEvents 関数]を使ったりします。

For Each f In fiLes
　　im.Picture = LoadPicture(f)
　　DoEvents:DoEvents
　　.PrintPreview
Next

これが DoEvents １コだと効きません。２コ以上必要みたい。
なぜと問われると「おまじないだから」と答えてしまいそうですが、
きっと訳があるのでしょうね。私には解らないけど。

ちなみに、Worksheet 上に配置するコントロールの種類によって挙動が違うようです。
Label や CommandButton は Image と同じです。
Frame には Repaint メソッドがあるから DoEvents は不要だろうと思って試してみたら
Repaint メソッドも不要で、ちゃんと描画されました。
よくわかりません。

■xl2000：yahooファイナンスとwebクエリ

ヤフーファイナンスからのデータダウンロードについて - 教えて！goo
この10月以降、xl2000の環境では上記Q&Aのコードでエラーが出るようになりました。
2002/2003は問題ないです。

確認のためマクロ記録した下記コードを実行してみるとエラーは出ませんが、データが取り込めません。

Sub Macro1()
　　With ActiveSheet.QueryTables.Add( _
　　　　　　　　　　 Connection:="URL;http://table.yahoo.co.jp/t?s=998407", _
　　　　　　　　　　 Destination:=Range("A1"))
　　　　.FieldNames = True
　　　　.RowNumbers = False
　　　　.FillAdjacentFormulas = False
　　　　.PreserveFormatting = False
　　　　.RefreshOnFileOpen = False
　　　　.BackgroundQuery = False
　　　　.RefreshStyle = xlOverwriteCells
　　　　.SavePassword = False
　　　　.SaveData = True
　　　　.AdjustColumnWidth = False
　　　　.RefreshPeriod = 0
　　　　.WebSelectionType = xlEntirePage
　　　　.WebFormatting = xlWebFormattingNone
　　　　.WebPreFormattedTextToColumns = True
　　　　.WebConsecutiveDelimitersAsOne = True
　　　　.WebSingleBlockTextImport = False
　　　　.WebDisableDateRecognition = False
　　　　.Refresh BackgroundQuery:=False
　　End With
End Sub

手作業で[新しいWebクエリ]を実行すると



こんなメッセージです。
自分では株もやらないので全然困らないのですが、急に取り込めなくなると困る方もいらっしゃるかもしれませんね。

推測ですけど、どうもyahooのソースコードが変わった事が影響している感じ。
上記 http://table.yahoo.co.jp/t?s= のページの場合だと47行目あたりに
...no-repeat;/*¥*//*/width:137px;height:16px;/**/}
という記述があります。（cssは詳しくないのですが、コメントか何か？）
ローカルにwebページを保存して確認してみると、この箇所が原因のようです。
xl2002以降ではwebクエリの仕様が変更になっていますから、2000だけ影響を受けたのでしょうか。
ソースが修正されるまでは別の方法で取り込むしかないようです。

■Dialogs(xlDialogInsertPicture)の引数

Application.Dialogs(xlDialogInsertPicture)...図の挿入ダイアログの事ですが、先日の xlDialogFilter の記事とは逆で、ヘルプに引数の記載はありますが、実際には機能しません。

（ヘルプの引数）
xlDialogInsertPicture file_name、filter_number

不勉強な私が知らないだけかもしれませんが、どうやっても file_name、filter_number が反映しないです。

Dim v
v = "sample.jpg"
'v = "d:¥tmp¥sample.jpg"
Application.Dialogs(xlDialogInsertPicture).Show v, 0 '1



バージョンアップの際のヘルプの修正忘れか何かでしょうかねぇ...


ついでに。
Dialog オブジェクトの Show メソッドの引数を、名前付きで使用したい場合は arg1,arg2...で使用できます。

Application.Dialogs(xlDialogSort).Show arg1:=xlTopToBottom, _
　　　　　　　　　　　　　　　　　　　 arg2:="列 A", _
　　　　　　　　　　　　　　　　　　　 arg3:=xlAscending, _
　　　　　　　　　　　　　　　　　　　 arg8:=xlNo