いままでのVBAコードが動かないのはなぜ?〜EXCEL2007問題


        目  次

コ  ン  テ  ン  ツ

非表示シートを原本として使用しコピーして表示する処理。 
オートフィルタの結果をコピーして別のシートに貼付ける処理
一瞬見えてしまう加工前の画像(ScreenUpdating = False)
挿入−図(図をファイルから挿入)ではアクティブセルに貼付けできない
シートのZoom値(表示倍率)によっては、正しい位置にオートシェイプを書込みできない
オートシェイプ内の文字フォントが変更できない(未解決)
2007で作成したBookが旧バージョンで開けない
グラフでマーカーを動かすことができない
画像ファイルのエクスポートで画像に白枠が付く
「セキュリティセンター」マクロが無効になりました
あのツールバーのボタンはどこへ行ったの?
フリーフォームがテキストボックスもどきになってしまうバグ
直線(オートシェイプ)の起終点を頂点(Nodes)で拾うことができない。
オートシェイプの名前の重複について。
条件付書式の設定で

MC-Applications
Return Top Page

レーシック fx


非表示シートを原本として使用しコピーして表示する処理。

以前まで動いていたコード
Sheets("****").Copy after:=ActiveSheet  '***は非表示シート
ActiveSheet.Visible = 1
コピー後のシートは非表示であるにもかかわらず、ActiveSheetで捕まえることができた。
考えてみたらそんなはずはない。

EXCEL2007対応コード

i = ActiveSheet.Index
Sheets("****").Copy after:=ActiveSheet  '***は非表示シート
With Sheets(i + 1)
  .Visible = 1
  .Activate
End With

※Copy after:=ActiveSheet だから With Sheets(i + 1)
Copy before:=ActiveSheet だったら With Sheets(i - 1)

目 次 へ


オートフィルタの結果をコピーして別のシートに貼付ける処理

以前まで動いていたコード
With Sheets("元シート")
  With .Rows(1)
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="AAA", Operator:=xlAnd  '等とオートフィルタをかけます
  End With
  .Range("A2", .Range("A65536").End(xlUp)).Copy _
      Destination:=Sheets("先シート").Range("A2")
End With
どこにも表示・非表示セルと指定していないのになぜフィルタ結果のみコピーできていたのか、今更ながら不思議。

EXCEL2007対応コード
With Sheets("元シート")
  With .Rows(1)
    .AutoFilter
    .AutoFilter Field:=1, Criteria1:="AAA", Operator:=xlAnd
  End With
  .Range("A2", .Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible).Copy _
      Destination:=Sheets("先シート").Range("A2")
End With

目 次 へ


一瞬見えてしまう加工前の画像(ScreenUpdating = False)

以下のコードはjpegファイル画像をシートの挿入しファイル容量節約のためJpeg形式で圧縮のうえ、画像縦横寸法を小さくするコードです。
画像が選択状態にならないよう途中でObject変数に代入し、セルにフォーカスを移していたのですが......

以前まで動いていたコード

Sub Macro1()
Dim x
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert("D:\My Pictures\200401_l.jpg").Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
Set x = Selection
ActiveCell.Activate
With x
  .ShapeRange.ScaleWidth 0.36, msoFalse, msoScaleFromTopLeft
  .ShapeRange.ScaleHeight 0.36, msoFalse, msoScaleFromTopLeft
End With
Application.ScreenUpdating = True
End Sub

'ActiveCell.Activate を実行した時点で処理途中の画像が見えてしまいました。
'Activate→Select としても同じでした

EXCEL2007対応コード

Sub Macro1()
Dim x
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert("D:\My Pictures\200401_l.jpg").Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
Set x = Selection
With x
  .ShapeRange.ScaleWidth 0.36, msoFalse, msoScaleFromTopLeft
  .ShapeRange.ScaleHeight 0.36, msoFalse, msoScaleFromTopLeft
End With
ActiveCell.Activate   '最後に持ってくる
Application.ScreenUpdating = True
End Sub

目 次 へ


挿入−図(図をファイルから挿入)ではアクティブセルに貼付けできない

EXCEL2000では、挿入−図−ファイルから
コードは
ActiveSheet.Pictures.Insert("D:\My Pictures\200402_l.jpg")
ですが、EXCEL2007では(手動では問題ないが)マクロの記録ができません。
また、上記コードでは、アクティブセルに貼付けできません。

対策:貼付け後にTop,Leftを指定して正しい位置へ移動するしかないと思います。

With ActiveSheet.Pictures.Insert("D:\My Pictures\200402_l.jpg")
.Top = ActivwSheet.Range("AA150").Top
.Left = ActivwSheet.Range("AA150").Left
End With

目 次 へ


シートのZoom値(表示倍率)によっては、正しい位置にオートシェイプを書込みできない

まず以下のコードをお試し下さい

Sub test()
Dim x As Object, MyZoom As Variant, SetZoom, i As Integer
SetZoom = Array(10, 15, 20, 25, 30, 35, 40, 45, 50, 55, 60, 65, 70, 75, 80, 85, 90, 95, 100)
MyZoom = ActiveWindow.Zoom
For i = 0 To UBound(SetZoom)
  ActiveWindow.Zoom = SetZoom(i)
  With Range("AA150")
    Set x = ActiveSheet.Shapes.AddShape(1, .Left, .Top, .Width, .Height)
    Debug.Print SetZoom(i) & "% :" & x.TopLeftCell.Address
    x.Delete
  End With
Next
ActiveWindow.Zoom = MyZoom
End Sub
Zoom値を10%〜100%まで変化させる中、四角いオートシェイプをAA150セルに描込み、TopLeftCell(オートシェイプの左上角のセル)がどうなるか調べています

結果は
10% :$Z$135
15% :$Z$135
20% :$AA$135
25% :$AA$135
30% :$Z$161
35% :$AA$157
40% :$Z$154
45% :$AA$151
50% :$AA$150
55% :$Z$148
60% :$AA$147
65% :$Z$146
70% :$AA$145
75% :$AA$144
80% :$Z$154
85% :$AA$152
90% :$Z$151
95% :$AA$150
100% :$AA$150

対策:オートシェイプ・図の位置決定処理の前にZoomを100%にし、処理後にもとのZoom値に戻す。
(Zoom値は50%の倍数であればずれないと判明しています。)
Sub test()
Dim x As Object, MyZoom As Variant, VW As Variant
MyZoom = ActiveWindow.Zoom
VW = ActiveWindow.View
Application.ScreenUpdating = False
ActiveWindow.Zoom = 100
ActiveWindow.View = xlNormalView
With Range("AA150")
   Set x = ActiveSheet.Shapes.AddShape(1, .Left, .Top, .Width, .Height)
End With
ActiveWindow.Zoom = MyZoom
ActiveWindow.View = VW
End With Application.ScreenUpdating = True
End Sub


但し、ユーザーがZoom値を変更する場合があるので、すべてのシェイプの位置決定処理の前後で行う必要がある。
また、改ページプレビュー表示を行うとZoom値が変化しますので、これも押さえる必要があります。
早い話が、MSのバグでしょう。

目 次 へ


オートシェイプ内の文字フォントが変更できない

< 未解決 >
現象のみの報告です。
 旧バージョンでは以下のマクロは問題ありません。
テキストボックスを作成し、クリック毎にフォントを変更します。

Sub Macro1()
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 69#, 46.5, 138#, 56.25)
  With .TextFrame
    .Characters.Text = "底辺:100cm" & Chr(10) & "高さ:50cm" & _
         Chr(10) & "三角形の面積" & Chr(10) & "100×50÷2=2500cm2"
    .Characters(Start:=9, Length:=1).Font.Superscript = True
    .Characters(Start:=18, Length:=1).Font.Superscript = True
    .Characters(Start:=42, Length:=1).Font.Superscript = True
    .AutoSize = True
    .Characters.Font.Name = "MS ゴシック"
    .Characters.Font.FontStyle = "標準"
  End With
  .OnAction = "FontChange"
End With
End Sub

Sub FontChange()
With ActiveSheet.Shapes(Application.Caller).TextFrame.Characters.Font
  If .Name = "MS ゴシック" Then
    .FontStyle = "太字 斜体"
    .Name = "MS P明朝"
  Else
    .FontStyle = "標準"
    .Name = "MS ゴシック"
  End If
End With
End Sub

EXCEL2007でテストするとFontStyleは無視されます。
.Name = "MS ゴシック" は数字のみが変更され、漢字については変更されません。

「ページレイアウト」リボンの「テーマ」が一部関係しているようなのですが、ユーザー定義テーマファイルの配布方法など問題があり解決していません。

これとは別の問題ですが、テキストボックスの見た目が変わってしまうというのもあり、調査中です。


掲示板へしーくさんから投稿がありました。

MSで現象と対策についてのアナウンスです。http://support.microsoft.com/kb/945500/ja

目 次 へ


2007で作成したBookが旧バージョンで開けない

旧バージョンで作成したEXCELファイル(拡張子 .xls)をEXCEL2007で開くとアプリケーションバー[互換モード]と表示され、 65536行256列のシートが表示されます。
ところが、EXCEL2007で新規Bookを作成すると1048576行 16384列のシートになります。
いまのところですが、これを旧バージョンで開けるファイルとして保存することができないようです。
開くコマンドのテキストファイル等の読込みでも、自動的に新規Bookが作成されるため、同様の事態となります。

以前まで動いていたコード

Sub test() '新規Bookを作って保存する
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="D:\TestTest.xls"
ActiveWorkbook.Close savechanges:=False
End Sub

EXCEL2007対応コード
Sub Test2()
ThisWorkbook.Worksheets.Add.Move
ActiveWorkbook.SaveAs Filename:="D:\TestTest2.xls", FileFormat:=xlWorkbookNormal
ActiveWorkbook.Close savechanges:=False
End Sub

旧バージョンで作成されたBookからVBAでの操作を前提としています。
[互換モード]Book上で作成したシートを移動すると、新規互換モードBookが作成されます。
ファイルフォーマットの指定も省略できません

テキストファイルの読込み場合は、自動で新規Bookができてしまいます。
セル上に並んだデータをActiveSheet.UsedRange.Copyで取り込み、上のコードで作成した[互換モード]Bookのシートに張付けてやることになります。
自動作成された新規Bookは、破棄します。

2010/3/5 追加情報

    .Add.Move を実行すると、Book内のオートシェイプやボタン類に登録したマクロのリンクがすべて書換えられてしまいます。
    原因については今のところ不明。(2000〜2003ではこのようなことはおこりません)

  HogeHoge(当初マクロ名) → Book1.xls!HogeHoge(実行後マクロ名)

    対症療法になりますが、以下のようなコードを仕込んでおくことが必要です。
    実行直後あるいは、プロシージャ終了までの間に
If Val(Application.Version) > 11 Then Call BottunLinkReNew
    というコードを挿入、以下のコードを呼出して実行する(Book名削除)

Sub BottunLinkReNew()
Dim B As Button, s As Worksheet

For Each s In Worksheets
  For Each B In s.Buttons
    If InStr(B.OnAction, "!") > 0 Then
      B.OnAction = Split(B.OnAction, "!")(1)
    End If
  Next
Next
End Sub

注)すべて自Book内のマクロが登録されている場合です。

目 次 へ


グラフでマーカーを動かすことができない

こちらは、VBAの問題ではありません。
シート上にグラフを作り、適当に作ったデータ範囲にリンクします。
例えば折れ線グラフで、旧バージョンではデータマーカーを上下に移動することができ、リンクされたデータの数値が変更されます。

Excel2007では、マーカーの移動ができません。
マクロの記録では、選択まではできているようなのですが。

この機能はなくなってしまったんですね。  Office TANAKA:グラフの系列をドラッグして値を変更

目 次 へ


画像ファイルのエクスポート

方法はいくつかあります。
  1. グラフに画像をセットしてExportする方法
  2. HTML形式で保存する方法
  3. APIを利用して出力する方法
  4. Excelファイルをバイナリで開き、Jpgのキーコードを元に画像データを切り出す方法
いずれも試してみましたが、画像の四囲に1ドット幅の白い枠が付いて出てきます。

どうやら、シートに画像を取込んだ時点で既にそういう状態に加工されているようなのです。

以下の手順で解決しましたが、長くなるので後日別のページにまとめたいと思います。

  1. まず、BMP形式でファイルに出力します。
  2. そのBMPをバイナリで読込み、白枠を削除して、BMPのまま保存します。
  3. できたBMPファイルを「明熊工房」さんの「saveJPG.dll」で、jpgに変換します。
  4. ということで、いまのところはBMPまたはJPGが最終形態です。
 

目 次 へ


「セキュリティセンター」マクロが無効になりました

Excel2007のマクロセキュリティはこれまでのEXCELと大きく異なります。
「オプション」ボタンを押して「このコンテンツを有効にする」- OK とすればマクロが使用できるようになります。

ただ、この方法では毎回この操作が必要でわずらわしいと感じてしまいます。

私のお勧めは「信頼できる場所」を設定すること。

左上の丸い見慣れないボタンがOfficeボタンです。
これをクリックして右下に「EXCELのオプション」とありますのでこれをクリック。
「セキュリティセンター」で右側 真ん中付近の「セキュリティ センターの設定」をクリック。
上から2番目「信頼できる場所」で下のほうに「新しい場所の追加」から、フォルダを指定します。

この中にあるEXCELファイルは、マクロの警告をださせずに利用できます。

目 次 へ


あのツールバーのボタンはどこへ行ったの?

ツールバーがなくなってしまい、リボンの改造はできません。
古いバージョンになれた方にとっては『あのボタンはどこへいったの?』といった事態が待っています。

そういった不便を解消するために『クイックアクセスツールバー』が搭載されています。

1.オフィスボタンからEXCELのオプション〜ユーザー設定、または、クイックアクセスツールバーを右クリックして、   クイックアクセスツールバーのカスタマイズを選択します。
  左上の丸い見慣れないボタンがOfficeボタンです。
  これをクリックして右下に「EXCELのオプション」とありますのでこれをクリック。

2.使えそうなアイコンをさがし、右側のリストへ追加します。


『クイックアクセスツールバー』の設定画面はボタン探しにはちょっと有効です。

『全てのコマンド』で、リストは50音順に並んでいますので,アイコンと説明を頼りにず〜〜〜っと見ていきます。
お目当てのコマンドを見つけたら、カーソルをその上に持って行きヒントを見ると

『-挿入』ですと『リボンにないコマンド|-挿入(MinusSign)』 とありますので、欲しければ自分で出すしかないのが判ります。
『インデント』ですと『ホームタブ|配置|インデント(IndentIncreaseExcel)』ですので、ホームタブの配置の所を見てみます。

判りにくいのは書式関連のやつで、『トリミング』では『[図ツール]|書式タブ|サイズ|トリミング・・・とあり、『図ツール』というのが図を選択したときに出現する という意味らしく そのときの『書式タブ』 とこうなるようです。

目 次 へ

フリーフォームがテキストボックスもどきになってしまうバグ


再現方法
Excel2000〜2003で新規Bookを作成します。(ここは既存のBookでもいいんですが、元に戻らなくなるので)
シート上にフリーフォームを配置します。
一度名前を適当につけてわかりやすいところへ保存します。
このファイルをExcel2007で開きます。
フリーフォームを選択すると,いきなりテキストボックスになります。

この現象はMicroSoftでも把握していますが、とりあえず対策がありません。
次の(といってもまだ一つも出ていませんが)サービスパックで対応してくれたらいいんですけど。

目 次 へ

直線(オートシェイプ)の起終点を頂点(Nodes)で拾うことができない。


今まで動いていたコード
Sub Macro1()
Dim i As Long, PointA

  With ActiveSheet.Shapes.AddLine(50, 100, 100, 50)
    With .Nodes
      For i = 1 To .Count
        PointA = .Item(i).Points
        MsgBox i & "番目 X=" & PointA(1, 1) & " Y=" & PointA(1, 2)
      Next
    End With
  End With
End Sub
なんということもない、直線を描いて起終点の座標値を拾ってます
Helpをみると「フリーフォーム」の記述が気にはなってましたが・・・

EXCEL2007では、CountがゼロになってForループが機能しません。

EXCEL2007対応コード
Sub Macro2()
Dim i As Long, PointA

With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, 50, 100)
  .AddNodes msoSegmentLine, msoEditingAuto, 100, 50
  With .ConvertToShape
    With .Nodes
      For i = 1 To .Count
        PointA = .Item(i).Points
        MsgBox i & "番目 X=" & PointA(1, 1) & " Y=" & PointA(1, 2)
      Next
    End With
  End With
End With
End Sub
直線を描くときにフリーフォームとうたってやります。
EXCEL2007は、解釈が厳密になっているようです。

Nodeを使わない手もあります。

Sub Macro3()
Dim L As ShapeRange  'for Selection
'Dim L As Shape      'for AddLine

Set L = Selection.ShapeRange

'Set L = ActiveSheet.Shapes.AddLine(50, 100, 100, 50)
'Set L = ActiveSheet.Shapes.AddLine(100, 100, 50, 50)
With L
  If .VerticalFlip Eqv .HorizontalFlip Then
    Debug.Print "左側座標 XL=" & .Left & " YL=" & .Top & vbCr & _
            "右側座標 XR=" & .Left + .Width & " YR=" & .Top + .Height
  Else
    Debug.Print "左側座標 XL=" & .Left & " YL=" & .Top + .Height & vbCr & _
            "右側座標 XR=" & .Left + .Width & " YR=" & .Top
  End If
End With
End Sub

Selectionで、シート上のシェイプを拾うと、ユーザーが回転をかけている場合がありますね。
計算量が増えちゃいますが、
Sub Macro4()
Dim Lin As Line
Dim T0 As Single, T1 As Single, T2 As Single
Dim L0 As Single, L1 As Single, L2 As Single
Dim X1 As Single, X2 As Single
Dim Y1 As Single, Y2 As Single
Dim HLength As Double
Dim A0 As Double, A1 As Double

If TypeName(Selection) <> "Line" Then Exit Sub
Set Lin = Selection
With Lin.ShapeRange
  L1 = .Left
  L2 = .Left + .Width
  If .VerticalFlip Eqv .HorizontalFlip Then
    T1 = .Top
    T2 = .Top + .Height
  Else
    T1 = .Top + .Height
    T2 = .Top
  End If
  A1 = Application.Radians(.Rotation)
End With
Set Lin = Nothing

A0 = Atn((T2 - T1) / (L2 - L1))
HLength = Sqr((T1 - T2) ^ 2 + (L1 - L2) ^ 2) / 2
T0 = (T1 + T2) / 2
L0 = (L1 + L2) / 2
'T0 = T1 + HLength * Sin(A0)
'L0 = L1 - HLength * Cos(A0)
X1 = L0 - HLength * (Cos(A0 + A1))
Y1 = T0 - HLength * (Sin(A0 + A1))
X2 = L0 + HLength * (Cos(A0 + A1))
Y2 = T0 + HLength * (Sin(A0 + A1))
Debug.Print "X1=" & X1 & " Y1=" & Y1 & " :X2=" & X2 & " Y2=" & Y2 & _
        ", Length=" & CSng(Sqr((X1 - X2) ^ 2 + (Y1 - Y2) ^ 2)) & _
        ", Rotation=" & Application.Degrees(A1) & "°"
End Sub

また、2007ではAddLineで引いた線分にAddNodes(頂点の追加)はできなくなってしまいました。
これは手動操作でも、マクロでもできません。
上記のような方法で、起終点の座標を取得して「フリーフォーム」で描き直すしかないと思います。

目 次 へ

オートシェイプの名前の重複について。


Excel2003まではマクロから名前を変更した場合に、同じ名前のオートシェイプがあるとエラーになるんで、それを利用して次のようなプロシージャを使っていました。
末尾のナンバーだけ書き換えて、欠番があればそこを埋めるというものです。

今まで動いていたコード

Sub SetShapeName(ByVal MyShape As Object)
Dim i As Long
Const ShN As String = "Shape "

On Error Resume Next
With MyShape
  Err.Number = 1
  Do Until Err.Number = 0
    Err.Number = 0
    i = i + 1
    .Name = ShN & i
  Loop
End With
On Error GoTo 0
End Sub

ところが、2007では、名前が重複していてもエラーになりません。
これは明らかに欠陥と言っていいと思いますが、対処はしなきゃいけないというのが悲しいところ。
とりあえずコレクションに入れて逃げておりますが、ほかにもっといい方法があるかも、です。

2007対応コード

Sub SetShapeName2(ByVal MyShape As Object)
Dim i As Long
Dim Col As New Collection
Dim s As Shape
Const ShN As String = "Shape "

On Error Resume Next
For Each s In ActiveSheet.Shapes
  If s.Name Like ShN & "*" Then Col.Add s.Name, s.Name
Next
With MyShape
  Err.Number = 1
  Do Until Err.Number = 0
    Err.Number = 0
    i = i + 1
    Col.Add ShN & i, ShN & i
  Loop
  .Name = Col(Col.Count)
End With
On Error GoTo 0
End Sub

名前の重複について

基本的には重複した名前はあり得ないというのが正しいと思いますが、2003までのバージョンでも同じ名前が作られてしまうことがありました。
オートシェイプを右ドラッグして、「ここにコピー」の操作です。
VBAでは、Duplicateメソッドにあたります。(いづれも同じ名前が付いてしまいます)
Microsoftでは、こちらをとしたのでしょうか?

目 次 へ

条件付書式の設定で


こちらは、変な話だったのが直ったのかなという話。
マクロで条件付書式を設定する場合、アクティブセルがどこか?という点が設定数式に影響を与えていました。

以下は単純な例ですが、

今まで動いていたコード

A2:B12の範囲の入力値が数字であればセル色を赤くする 条件付書式を設定するコード。
Sub Macro1()
With Range("A2:B12")
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:="=ISNUMBER(" & ActiveCell.Address(0, 0) & ")"
    .FormatConditions(1).Interior.Color = vbRed
End With
End Sub
こうしないととんでもないところを見に行ってました。
ちなみに他のセルを参照する場合は、ActiveCell.Offset(2,3).Address(0, 0) などとします。

2007対応コード

Sub Macro2()
With Range("A2:B12")
    .FormatConditions.Delete
    .FormatConditions.Add Type:=xlExpression, Formula1:="=ISNUMBER(A2)"
    .FormatConditions(1).Interior.Color = vbRed
End With
End Sub
えらいすっきりしたなぁ。
要するにバグだったんですね。

ちょっとわかりにくいようなので例をもう一つ。

対応コード例

Dim MyStr As String, a

MyStr = ""
With Union(Range("A1:C5"), Range("A11:C15"), Range("A21:C25"))
    .FormatConditions.Delete
    For Each a In .Areas
        If Val(Application.Version) < 13 Then
            MyStr = IIf(Len(MyStr) = 0, "=", MyStr & "+") & _
                    "COUNTIF(" & a.Cells.Address _
                       & "," & ActiveCell.Address(0, 0) & ")"
        Else
            MyStr = IIf(Len(MyStr) = 0, "=", MyStr & "+") & _
                    "COUNTIF(" & a.Cells.Address _
                        & "," & a.Cells(1).Address(0, 0) & ")"
        End If
    Next
    .FormatConditions.Add Type:=xlExpression, Formula1:=MyStr & ">1"
    With .FormatConditions(1)
        .Font.Bold = True
        .Interior.ColorIndex = 6
    End With
End With
見てわかるかと思いますが、複数のエリアを持つ範囲の重複データを セル色=黄色、文字色=赤、太字 で表示させます。
上の方がEXCEL2003まで、下はEXCEL2007以上。
検査範囲は絶対アドレスなので、そのままでいけます。 a.Cells.Address
(複数範囲対応は =COUNTIF(・・・)+COUNTIF(・・・)+COUNTIF(・・・)>1 になってます)

相対セル参照が2003以下ではうまくいかないので、ActiveCellを使います。
2007以上では、検査範囲エリアの先頭セルを相対アドレスで a.Cells(1).Address(0, 0) のように使います。

目 次 へ