カテゴリ:マクロ( 42 )

任意数で四角(オートシェイプ)を描く

同一図形をたくさん作る必要があったので今回はそのマクロを。
もちろんコピー貼り付けでも良かったのだが・・・

Sub 任意の数でオートシェイプを作る()
Dim i As Integer
Dim kosu As Integer

 kosu = Application.InputBox("1個以上の数字を入力")

  For i = 1 To kosu
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 20 * i, 20, 20, 20).Select
  Next
End Sub
e0080122_22424483.gif

数字を入力するインプットボックスを表示させてその中に任意の個数を入力。
e0080122_22451216.gif

[PR]
by slayer0210 | 2005-12-09 22:45 | マクロ

トリミングもどき

シートに写真を挿入して必要ない部分はトリミングという作業をする。
このトリミング作業のときに、オートシェイプ(四角)の枠線と同じサイズにするマクロを。
無理やり組んだ気がするし、糞の役にもたちそうにないが。
e0080122_22104124.gif

Option Explicit
Dim 写真top As Single, 写真left As Single, 写真width As Single, 写真height As Single
Dim ものさしtop As Single, ものさしleft As Single, ものさしwidth As Single, ものさしheight As Single
Dim mypic As Object
Dim ものさし As Shape

Sub 写真セット()
Dim myFname As String
 myFname = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")

On Error Resume Next
ActiveSheet.Shapes("写真").Delete
ActiveSheet.Shapes("ものさし").Delete

If myFname = "False" Then Exit Sub

  Set mypic = ActiveSheet.Pictures.Insert(myFname)
    With mypic
      .Name = "写真"
      .Top = 0
      .Left = 0
    End With
       Call ものさし表示
End Sub

Sub 偽トリミング()
Set mypic = ActiveSheet.Shapes("写真")
Set ものさし = ActiveSheet.Shapes("ものさし")
'本来以下はどうでもいいけど、頭が混乱しそうなので書いた
 写真top = mypic.Top
 ものさしtop = ものさし.Top
 写真height = mypic.Height
 ものさしheight = ものさし.Height
 写真left = mypic.Left
 ものさしleft = ものさし.Left
 写真width = mypic.Width
 ものさしwidth = ものさし.Width
’混乱を防ぐつもりがますます混乱してしまった。あとで作り直そう。

  With mypic
     With .PictureFormat
      .CropTop = ものさしtop - 写真top
      .CropBottom = (写真top + 写真height) - (ものさしtop + ものさしheight)
      .CropLeft = ものさしleft - 写真left
      .CropRight = (写真left + 写真width) - (ものさしleft + ものさしwidth)
    End With
   .Name = ActiveSheet.Pictures.Count
  End With
     ものさし.Delete
End Sub

Sub ものさし表示()
With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 10, 10, 50, 50)
.Fill.Visible = msoFalse
.Line.Weight = 2.25
.Line.ForeColor.SchemeColor = 10
.Name = "ものさし"
.Select
End With
e0080122_22202769.gif

非常に無理やりだったが、目的のものが出来たのでまぁ良かった。
[PR]
by slayer0210 | 2005-12-08 22:23 | マクロ

図形を動かす

今回は遊びで図形を動かしてみることにした。
図形といってもクリップアートを挿入しただけの手抜き作業だ・・・
キー操作(←、→)で図形の動く方向を決めて、スペースキーでこのマクロを中止してみる。
e0080122_12515937.gif

Option Explicit
Declare Function GetAsyncKeyState Lib "user32.dll" (ByVal vkey As Long) As Long

Sub 動く車()
 Dim mycar As Shape
 Dim myflg As Boolean
 Dim x As Integer
  Set mycar = ActiveSheet.Shapes("車")
  myflg = True
  x = 0

  Do While myflg = True
     If GetAsyncKeyState(39) <> 0 Then'右方向キー
       x = 1
     End If

    If GetAsyncKeyState(37) <> 0 Then'左方向キー
      x = -1
    End If

    If GetAsyncKeyState(32) <> 0 Then'スペースキー
       myflg = False
    End If
        mycar.IncrementLeft x
          DoEvents
  Loop
End Sub
[PR]
by slayer0210 | 2005-12-06 13:00 | マクロ

オートシェイプの真ん中に文字を入れる

オートシェイプに文字を入れる場合は、右クリックして『テキストの追加』を選択する。
しかし下図のように上詰め、左寄せに入ってしまい、後から色々と調整しなければならない。
e0080122_8434575.gif

これをマクロでやるとどうなるのか?ためしにやってみた。
今回はテキスト部分はA1に入力した文字をそのまま使ってみることにした。

Sub ど真ん中に配置()
 Dim 楕円 As Shape
 Set 楕円 = ActiveSheet.Shapes("en") '予めオートシェイプに名前をつけてある
   With 楕円.TextFrame
     .Characters.Text = Range("A1").Value
     .HorizontalAlignment = xlHAlignCenter
     .VerticalAlignment = xlVAlignCenter
   End With
End Sub
e0080122_849792.gif

[PR]
by slayer0210 | 2005-12-06 08:50 | マクロ

タイマー(未完成)

今回はオートシェイプで時計みたいな図を描き、その針を1秒ごとに動かして3分間計測するものを作ってみた。
使用目的は、自分がラーメンを作る際に利用できないか?的な感じだが。
e0080122_9493.gif

Sub ラーメン時計()
 Dim myobj As Shape
 Dim i As Integer
 Dim j As Integer
 Set myobj = ActiveSheet.Shapes("針")

 With myobj
  For j = 1 To 3
    For i = 1 To 360 Step 6
      Application.Wait (Now + TimeValue("0:00:01"))
        .IncrementRotation 6
     Next
   Application.Speech.Speak j & "分" 'しゃべらす必要はないが
  Next
 End With
   Application.Speech.Speak "ラーメンが出来ました"
   'しゃべらす必要はないがめでたいので・・・
End Sub

構文的にあってるかどうかは別として、目的のものは出来たので良かった。
しかし実際問題、ラーメンは2分半くらいが一番旨い・・・と思う。
[PR]
by slayer0210 | 2005-12-01 09:10 | マクロ

シート名の変更

あまり使わないが、セルに新しいシート名を入力して変更するマクロを・・・
さらにシートタブの色も変更させてみた(これはオマケ)

Sub シート名変更()
 Dim mySnum As Integer
 Dim i As Integer

  mySnum = ActiveSheet.Range("a65536").End(xlUp).Row

 For i = 1 To mySnum
   With Sheets(i)
     .Name = Cells(i, 1).Value
     .Tab.ColorIndex = i + 3 '色は何でもよかった・・・
   End With
 Next
End Sub
e0080122_10544135.gif

[PR]
by slayer0210 | 2005-11-29 10:55 | マクロ

セルの値をコメントに置き換え

あまり糞の役にも立ちそうにないが、セルの値をコメントに置き換えるマクロを作ってみた。
予めF列にコメントを追加するアドレスを入力しG列にコメントを入力しておく。
そしてマクロを実行する。
e0080122_23423385.gif

 Sub コメントに置き換え()
  Dim i As Long
  Dim myadd As String
  Dim mystr As String

    For i = 1 To Range("F65536").End(xlUp).Row
      With Cells(i, 6)
        myadd = .Value
        mystr = .Offset(, 1).Value
      End With

      With Range(myadd)
        On Error Resume Next
          .Comment.Delete 'とりあえず存在するコメントを消す
        On Error GoTo 0
          .AddComment (mystr) 'コメントを追加する
      End With
   Next
 End Sub
e0080122_2350331.gif

[PR]
by slayer0210 | 2005-11-25 23:51 | マクロ

罫線のみ削除するマクロ

表の罫線のみを削除したい場合は、通常は罫線ボタンを使ったり、セルの書式設定の罫線タブを使ったりする。
別にマクロにする必要もなかったのだが・・・

Sub 罫線のみ削除()
Dim myrange As Range
Set myrange = Selection.CurrentRegion
myrange.Borders.LineStyle = xlNone
Set myrange = Nothing
End Sub

あまりにも単純だが、アクティブセルの領域内の表を消すって点だけが良かった。
e0080122_8484224.gif

[PR]
by slayer0210 | 2005-11-24 08:49 | マクロ

横方向の表を縦方向に

e0080122_7313821.gif
めったにないかもしれないが、上図の様にデータが横方向に並んだ表があったとしたら
後々集計するのが難しい場合がある。
そんな時に、この表を分解して縦方向へと作成するマクロを作ってみた。

Sub 縦方向の表へ()
 Dim c As Long
 Dim r As Long
 Dim i As Long
 Dim j As Long

  r = Sheets(1).UsedRange.Rows.Count

  With Sheets(2).Range("a1")
    .Value = "購入者"
    .Offset(, 1).Value = "商品名"
  End With 'とりあえずSheet2に放出するために準備

 For i = 2 To r
   c = Sheets(1).Cells(i, 1).End(xlToRight).Column
     For j = 2 To c
       If Sheets(1).Cells(i, j).Value <> "" Then
         With Sheets(2).Range("B65536").End(xlUp)
            .Offset(1).Value = Sheets(1).Cells(i, j).Value
            .Offset(1, -1).Value = Sheets(1).Cells(i, 1).Value
         End With
       End If
     Next
 Next
End Sub

何だかかなり無理やり・・・な感じもするが、一応目的の表は出来たので良しとする。
e0080122_7402969.gif

[PR]
by slayer0210 | 2005-11-22 07:42 | マクロ

目次シートの作成(相互リンク?)

目次シートの作成でも紹介したが、今回は目次シートから目的シートへと移動した後に
目次へのハイパーリンクを設定してみた。
おのおののシートのA1に"目次シートへ"という感じにしてみる。

Sub 目次シート作成()'シート間の相互リンク?
Dim mysheet As Worksheet
Dim i As Integer

 For Each mysheet In Worksheets
    If mysheet.Name = "目次シート" Then
       Application.DisplayAlerts = False
          mysheet.Delete
       Application.DisplayAlerts = True
    End If
 Next
   Worksheets.Add before:=Worksheets(1)
   ActiveSheet.Name = "目次シート"

 For i = 2 To Worksheets.Count
    Cells(i - 1, 1).Value = Sheets(i).Name
      ActiveSheet.Hyperlinks.Add Anchor:=Cells(i - 1, 1), Address:="", _
      SubAddress:=Cells(i - 1, 1).Value & "!" & "A1"
 Next

 For i = 2 To Worksheets.Count
  Worksheets(i).Activate
   ActiveSheet.Hyperlinks.Add Anchor:=Cells(1, 1), Address:="", _
SubAddress:="目次シート!A1", TextToDisplay:="目次シートへ"
Next
End Sub
e0080122_21431217.gif

[PR]
by slayer0210 | 2005-11-20 21:44 | マクロ