(続)EXCEL VBA のコードをズバリで!

このQ&Aのポイント
  • 円の雛型の各種設定が保存・呼び出しで初期化される不具合。急遽、円を生成することに。
  • .Ovals.Add(200, 0, 20, 20) についての質問
  • .Border.LineStyle の点線の記号定数や文字の垂直方向指定に関する質問
回答を見る
  • ベストアンサー

(続)EXCEL VBA のコードをズバリで!

http://okwave.jp/qa/q6535908.html で、完成かと思われましたが・・・。 円の雛型の各種設定が保存・呼び出しで初期化されるという不具合が発生。 急遽、円を生成することにしました。 そこで、次の質問を致します。 質問1、.Ovals.Add(200, 0, 20, 20) は、これでよいのでしょうか? 質問2、.Border.LineStyle で点線の記号定数 質問3、文字の垂直方向の指定要領・・・中心 質問4、内部の余白の指定要領・・・上下を0に なお、現在の円を生成するコードは次のようです。 Sub cmdUpdateSokueki_1()   Set myDocument = Worksheets("調査データ")   Dim r As Range ' 読み込むRange   ・・・・・   Dim shapeCounter As Integer ' 描画する円のカウンター(=name)   With myDocument     For Each r In .Range("C15", .Range("C65536").End(xlUp))       ・・・・・       If tubeState >= 0 Then         ・・・・・         createShapes_1 "特殊部管理台帳", shapeCounter, shapeNumber, tubeState, shapeDiameter         ・・・・・       End If     Next r   End With End Sub 更新Subが呼び出す Sub です。 Public Sub createShapes_1(ByVal sheetName As String, _              ByVal shapeCounter As Integer, _              ByVal shapeNumber As Integer, _              ByVal tubeState As Integer, _              ByVal shapeDiameter As Single)   Set myDocument = Worksheets(sheetName)   Dim intLeft As Integer   Dim intTop As Integer   With myDocument     intLeft = .Range("I37").Offset(, (shapeCounter Mod 7) * 2).Left     intTop = .Range("I37").Offset((shapeCounter \ 10) * 2, 0).Top     With .Ovals.Add(200, 0, 20, 20)       Select Case tubeState         Case 0           .Border.LineStyle = msoLineSolid ' 本来は点線 ********           .Interior.Color = vbWhite           .Font.Color = vbWhite         Case 1           .Border.LineStyle = msoLineSolid           .Interior.Color = vbWhite           .Font.Color = vbBlack         Case 2           ・・・・・         Case Else       End Select       .Name = "oval100" & Format(shapeCounter, "00")       .Placement = xlMove       ・・・・・       .Left = intLeft       .Top = intTop       .Orientation = 3     End With   End With End Sub PS:一応は所定の位置に円を描画しています。

noname#140971
noname#140971

質問者が選んだベストアンサー

  • ベストアンサー
  • end-u
  • ベストアンサー率79% (496/625)
回答No.2

私が前回のレスでOvalsを使ったのはまずかったですね。 隠しObjectなのでヘルプ等で確認できません。 素直にShapeを使ってください。失礼しました。 ところでExcelのバージョンは何でしょう? 2007以外ではマクロ記録が参考になります。 ただし、Shape操作時の Selection が TextFrame になる事がありますからその点は気をつけてください。 Sub try3() 'ステップ実行推奨   Dim sp As Shape   Dim L As Single   Dim T As Single   Dim W As Single   Dim H As Single   L = 10   T = 20   W = 30   H = 40   Set sp = ActiveSheet.Shapes.AddShape(msoShapeOval, L, T, W, H)   With sp     '最初にテキスト追加しないと後のTextFrame操作でエラー     .TextFrame.Characters.Text = ""     '線に対する処理     .Line.DashStyle = msoLineSquareDot     .Line.DashStyle = msoLineRoundDot     .Line.DashStyle = msoLineDash     .Line.DashStyle = msoLineSolid     .Line.ForeColor.RGB = RGB(255, 255, 255)     .Line.ForeColor.RGB = RGB(0, 0, 0)     .Line.Weight = 1     '背景に対する処理     .Fill.ForeColor.RGB = RGB(0, 0, 0)     .Fill.ForeColor.RGB = RGB(255, 255, 255)     'TextFrameに対する処理     .TextFrame.Characters.Text = "aa"     .TextFrame.Characters.Font.Color = vbWhite     .TextFrame.Characters.Font.Color = vbBlack     .TextFrame.HorizontalAlignment = xlCenter     .TextFrame.VerticalAlignment = xlCenter     .TextFrame.HorizontalAlignment = xlLeft     '余白、向き     .TextFrame.MarginLeft = 0     .TextFrame.MarginRight = 0     .TextFrame.MarginTop = 0     .TextFrame.MarginBottom = 0     .TextFrame.Orientation = 3     .TextFrame.Orientation = 2     .TextFrame.Orientation = 1   End With   Set sp = Nothing End Sub

noname#140971
質問者

お礼

お礼が遅くなってしまいました。 2倍速になったのでプログラムをさぼっていました。 本日、只今、オブジェクトをShapeに修正しました。 実際に作業してみたところ60分が20分まで短縮されました。 これで余裕を持って作業をすることができます。 本当にありがとうございました。 現場の担当者の方も、2倍速でもものすごーく喜んでいます。 3倍速ですと、とってもだと推察されます。 本当にありがとうございました。

noname#140971
質問者

補足

バージョンは2007です。 点線で描画されれば、ほぼ完成でした。 記号定数ではなく1,2と試しましたが、点線がなく当惑していたところです。 Ovalsを使っても、ほぼ作業時間を半減することに成功しました。 現実問題としては、余白の操作はしないでフォントサイズを小さくして対応していたからです。 だから、手作業は一部の円を点線にする作業のみだったからです。 まあ、それでも100%手作業を廃止してなんぼですのでShapesを使います。 朝と夜も別の仕事をしていますので、パソコンに向かうのは夜に2、3時間のみ。 離島住まいという環境ですので書籍もありません。 そういう事情で厚かましく質問を重ねた次第です。 先ずは、補足欄にてお礼をしておきます。

その他の回答 (1)

  • layy
  • ベストアンサー率23% (292/1222)
回答No.1

前回、洩れが起こりそうだと言ったのに。 甘く見ない方が良い。 大袈裟にいえば、この前新幹線5路線止まったのも小さなミスからです。 もう一度言っておきます。 100%を求めること。100%の説明であり、100%のテストであり、確認であり。説明不足は洩れを招きます。 回答はテストしていないまま提供している、というつもりで自分で確認、保持するべき。 なので、 再度、伝え洩れは無いか、です。

noname#140971
質問者

お礼

>再度、伝え洩れは無いか、です。 それは、本当の所は判りません。 が、あくまでも現時点では無いと思っていますが・・・。 この怪しさが、確かに問題です。 さて、前回の指摘を受けて・・・。 「おい、本当にこれは役所に提出するのかい?」 「アハア!そんな訳ないだろうが!」 「エッ!」 「国土交通省ってのは、実は富○建設のあだ名さ!」 「島で一番の土建屋の富○建設かい?」 「そんなの常識だぜ!」 と、島暮らし一ヶ月の私にとっては驚きの答えでした。 「6割がたあっていればいいさ!アハハ!」 実は、どうでもよい土建屋の私的な調査資料だったと知って愕然です。 少し、状況に関して訂正しておきます。 しかし、ズバリのコードが無いとプログラミングできない自分が実に情けないです。 まあ、そこら辺りはシルバー人材センターの限界だと思ってください。 それはそれとして、回答者の指摘は<肝に銘じて>教訓にしたいと思います。 重ねての指摘、本当にありがとうございます。

関連するQ&A

  • エクセル2010のvbaについて

    押されたコマンドボタンの名前を取得したいです (調べてみましたがエラーになり取得できませんでした) 後コマンドボタンがたくさんあり、コードも長く とても邪魔なので省略したいのですができますか? (左クリックと右クリックで違う処理をした後       MouseDown コマンドボタンの名前で少し処理を変えるコードです) MouseUp (下のコードのような感じです) 回答お願いします Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Select Case Button Case 1 Range("A1") = 1 Case 2 Range("A1") = 2 End Select End Sub Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) If (コマンドボタンの名前を取得) = "aaa" Then Range("A1") = Range("A1") + 1 Else Range("A1") = Range("A1") - 1 End If End Sub

  • EXCEL 異なるVBA

    教えて下さい、EXECL以下の異なるVBA (A>,B>)が2つあります、同じシートでそれぞれ動くようにさせたいです1つに合わせる事は出来ないでしょうか? 当方初心者の為わかりません教えて下さい。 A> Private Sub Worksheet_Change(ByVal Target As Excel.Range) If Target.Address(0, 0, xlA1, 0) <> "A1" Then Exit Sub With Range("F9:I9,K17:K36").Borders(xlDiagonalUp) If Left$(Target.Value, 1) = "S" Then .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic Else .LineStyle = xlNone End If End With End Sub B> Private Sub Worksheet_Change(ByVal Target As Range) With Sheet2 Select Case Target.Address Case Is = "$D$1" .Range("A1").Insert Shift:=xlDown .Range("A1").Value = Target.Value Case Is = "$D$2" .Range("B1").Insert Shift:=xlDown .Range("B1").Value = Target.Value End Select End With End Sub

  • EXCEL VBAでHPageBreaks

    いつもお世話様です。 こちらで教えていただいたマクロでフッダーの前に自動で罫線を引こうとしています。 前の質問は→http://okweb.jp/kotaeru.php3?q=1310420 下記のマクロを動かすと、1ページだけの時はちゃんとフッダーの上に罫線が引けますが、2ページ目になると「インデックスが有効範囲にありません」という実行時エラーが出てしまいます。 どこがいけないのでしょうか? Sub 自動罫線TEST() Dim BreakSu As Integer Dim BreakSu2 As Integer Dim B As Integer Dim Rw As Long Dim LastRow As Long For N = 1 To 3 With Cells .ClearContents .Borders(xlEdgeTop).LineStyle = xlNone .Borders(xlEdgeBottom).LineStyle = xlNone .Borders(xlInsideHorizontal).LineStyle = xlNone End With Range("A1:D" & N * 30) = N & N & N 'TESTデータ挿入 LastRow = Range("A65536").End(xlUp).Row '最終行取得 BreakSu = ActiveSheet.HPageBreaks.Count '改ページ数取得 Range(Cells(LastRow + 1, "A"), Cells(LastRow + 100, "A")) = "ABC" '改ページ数を増やすダミー BreakSu2 = ActiveSheet.HPageBreaks.Count '増えた改ページ数取得 For B = 1 To BreakSu + 1 ' MsgBox B & "-" & BreakSu + 1 & "-" & BreakSu2 Rw = ActiveSheet.HPageBreaks(B).Location.Row - 1 '改ページ前行取得(ここでエラー!) With Range(Cells(Rw, "A"), Cells(Rw, "D")).Borders(xlEdgeBottom) '改ページ前罫線挿入 .LineStyle = xlContinuous End With Next B Range(Cells(LastRow + 1, "A"), Cells(LastRow + 100, "A")) = ClearContents 'ダミー消去 ActiveSheet.PrintPreview Next End Sub

  • VBAのシートイベントで教えてください

    シートのN4以下で、既に同じ番号があれば「既に同じ番号があります」 と表示するようにしたく、下のように書きましたが、肝心な部分 の、どのように同じ番号をみつけるようにすのかわかりませんでした。 教えていただけないでしょうか。宜しくお願いします。 Private Sub worksheet_change(ByVal target As Range) Dim 範囲左 As Integer Dim 範囲右 As Integer Dim 範囲上 As Integer 範囲左 = 1 範囲右 = 16 範囲上 = 4 With target 'if '指定した範囲の列Nに既に同じ番号や文字列があれば MsgBox "既に同じ番号があります。" End If End With End Sub

  • エクセル2010のコマンドボタンついて

    MouseDownイベントでループ(Doなど)をさせた後 MouseUpイベントでStopさせるコードを作りましたが MouseUpイベントまで行かずずっとループしてしまいます (押されている間はボタンが凹んでいますが このコードにすると凹まず中断しないと 動かせないようになってしまいます) 何が原因がわからないので回答お願いします 下はコードです Private Sub CommandButton1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Select Case Button Case 1 Range("A1") = 1 Case 2 Range("A1") = 3 End Select Do Range("A1") = Range("A1") + Range("A1") Loop End Sub Private Sub CommandButton1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) Stop End Sub (Select Case Button Case 1...にしても変わりませんでした)

  • エクセルのVBAコードにつてい

    以下のコードについて、その内容をまだ自分の知識では理解できず困っておりまして、アドバイスいただければと思いまして書き込みました。 『コード』 Sub Test() Dim Lc As Integer Dim Ct As Integer Dim MyR As Range Dim C As Range Dim D As Range Lc = Range("A1").End(xlToRight).Column - 2 For Each C In Range("B2", Range("B65536").End(xlUp)) Ct = WorksheetFunction.Count(C.Offset(, 1).Resize(, Lc)) If Ct > 0 Then Set MyR = C.Offset(, 1).Resize(, Lc).SpecialCells(2, 1) For Each D In MyR With Sheets("Sheet2").Range("A65536").End(xlUp) .Offset(1).Value = C.Value .Offset(1, 1).Value = Cells(1, D.Column).Value End With Next Set MyR = Nothing End If Next With Sheets("Sheet2") .Columns("A:B").AutoFit .Activate End With End Sub 『質問』 1.「Lc = Range("A1").End(xlToRight).Column - 2」の部分の解釈は「A1から右方向に一番最後のセルまでを範囲指定し、その一番右のセルの列番号を取得する」変数という解釈でいいのか 2.「Ct = WorksheetFunction.Count(C.Offset(, 1).Resize(, Lc))」の部分の変数はどういった値の整数を取得する変数なのか 以上2点についてアドバイスいただけると幸いです。

  • VBA  エラー

    Sub 上下カット1() Dim MyR As Range, MyMax As Integer, MyMin As Integer Dim MX As Range, MN As Range With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D15:P15")) MyMin = WorksheetFunction.Min(.Range("D15:P15")) For Each MyR In .Range("D15:P15") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D16:P16")) MyMin = WorksheetFunction.Min(.Range("D16:P16")) For Each MyR In .Range("D16:P16") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With End Sub を実行すると、 MX.Borders(xlDiagonalUp).LineStyle = xlContinuous の部分にエラーがでます。 対処方法を教えてください。

  • VBA エラー

    Sub 上下カット1() Dim MyR As Range, MyMax As Integer, MyMin As Integer Dim MX As Range, MN As Range With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D15:P15")) MyMin = WorksheetFunction.Min(.Range("D15:P15")) For Each MyR In .Range("D15:P15") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With With ActiveSheet MyMax = WorksheetFunction.Max(.Range("D16:P16")) MyMin = WorksheetFunction.Min(.Range("D16:P16")) For Each MyR In .Range("D16:P16") If MyR.Value = MyMax Then Set MX = MyR If MyR.Value = MyMin Then Set MN = MyR Next MX.Borders(xlDiagonalUp).LineStyle = xlContinuous MN.Borders(xlDiagonalUp).LineStyle = xlContinuous End With End Sub を実行すると”オブジェクト変数またはWithブロック変数が設定されていません。”と出ます。 どうしたらいいですか?

  • excel vba 遅延のソースゴード

    excel vba で動作させたものを動作の遅延をさせたいのですが、本コーナーで教えて頂いた下記の コードをどの様に使えばいいのでしょうか。 Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub Sample()   Range("A1") = 0   For i = 1 To 10     Sleep 500 '500msec(0.5秒)待機     Range("A1") = i   Next i End Sub ーーーーーーーーーーーーーーーーーー (bf38:bn38)を赤  (bo38:by38)を緑にします。この動作を赤から緑になるまでに少し遅延させたいのです。mt2008さんに教えて頂きましたが解決できませんでした。継続して再質問させていただきたかったのですが、方法がわかりませんでしたので、このような形になりましたお許し下さい。 Range("BF38:Bn38").Select With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 3 End With Range("Bo38:By38").Select With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ColorIndex = 4 End With End Sub

  • Excel VBA 引数が2個のマクロの呼び出し方

    ExcelのVBAで、 シート上のボタンがクリックされた時に呼び出す マクロ(プロシージャ)の引数が1個の時は、 コード1のようにできましたが、 引数が2個ある時は、コード2のように記述しても、 ボタンをクリックするとエラーになりますが、 【?】の部分をどのように記述すればよいのでしょうか。 (Windows10,Excel2010) -------------------コード1---------------------------------------- Sub test1()  Dim row As Integer  Dim wave_file_path As String  For row = 1 To 2   wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value   Call ボタン作成(row, wave_file_path)  Next row End Sub Sub ボタン作成(ByVal row As Integer, ByVal wave_file_path As String)  Dim cell_loc As String  cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address  ThisWorkbook.Worksheets("Sheet1").Select  With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _   Range(cell_loc).Top, _   Range(cell_loc).Width, _   Range(cell_loc).Height)   .name = "ボタン_" & cell_loc   .OnAction = "'WAVE_PLAY """ & wave_file_path & "" & "'"   .Characters.Text = "再生"  End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String)  If Dir(wave_file_path) = "" Then   MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation   Exit Sub  End If  Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path End Sub ------------------------------------------------------------------- -------------------コード2---------------------------------------- Sub test2()  Dim row As Integer  Dim wave_file_path As String  For row = 1 To 2   wave_file_path = ThisWorkbook.Worksheets("Sheet1").Cells(row, 1).Value   Call ボタン作成(row, wave_file_path)  Next row End Sub Sub ボタン作成(ByVal row As Integer, ByVal wave_file_path As String)  Dim cell_loc As String  cell_loc = ThisWorkbook.Worksheets("Sheet1").Cells(row, 3).Address  ThisWorkbook.Worksheets("Sheet1").Select  With ActiveSheet.Buttons.Add(Range(cell_loc).Left, _   Range(cell_loc).Top, _   Range(cell_loc).Width, _   Range(cell_loc).Height)   .name = "ボタン_" & cell_loc   .OnAction = "'WAVE_PLAY """ & wave_file_path & "" & "," & row & "'" <==【?】   .Characters.Text = "再生"  End With End Sub Sub WAVE_PLAY(ByVal wave_file_path As String, ByVal row As Integer)  If Dir(wave_file_path) = "" Then   MsgBox wave_file_path & vbCrLf & "がありません。", vbExclamation   Exit Sub  End If  Shell "C:\Program Files\Windows Media Player\wmplayer.exe /play /close " & wave_file_path  ThisWorkbook.Worksheets("Sheet1").Cells(row, 4).Value = "再生済" End Sub -------------------------------------------------------------------

専門家に質問してみよう