カテゴリ:マクロ( 42 )

任意でシート名を並べ替える

先日の話。自分が扱ってるエクセルブックで、やたらにシート数が多いものがある。
自分なりの使い勝手を考えて、任意で並べ替えようと思い、簡単なマクロを作ってみた。

Sub シート名を表示()
 Dim zWS As Worksheet
 Dim myWS As Worksheet
 Set zWS = Sheets.Add(before:=Sheets(1))
 zWS.Name = "暫定"
   For Each myWS In Worksheets
     If myWS.Name <> "暫定" Then
       Sheets("暫定").Range("a65536").End(xlUp).Offset(1) = myWS.Name
     End If
   Next
    Rows(1).Delete
End Sub

とりあえず、上記のマクロを実行すれば下図のように現在のシート名が暫定シートに表示される。
その後、暫定シートのA列に表示されたシート名を任意で並べる。
e0080122_7284153.gif

並べ替えが完了したら、以下のマクロを実行してみた。

Sub シートの並べ替え()
 Dim myWS As Worksheet
 Dim zWS As Worksheet
 Dim i As Integer
  Set zWS = Sheets("暫定")
    For i = 1 To zWS.Range("A1").CurrentRegion.Rows.Count
      Sheets(zWS.Cells(i, 1).Value).Move before:=Sheets(i)
    Next
   Application.DisplayAlerts = False
     zWS.Delete
   Application.DisplayAlerts = True
End Sub
e0080122_736351.gif

任意にシート名が並べ替えられた。
ま、構文的にどうかは別として目的のものが出来たのでよしとする。
[PR]
by slayer0210 | 2006-03-16 07:38 | マクロ

任意のシートを必要分だけコピーする(12枚)

先日、ある人が明細書の雛形のようなものを見せ、こう言った。
「これを12か月分欲しいから、ケツに12枚コピーして、シートの名前も変更しといて」と。
ちょうど暇だったので、手作業でコピーしても良かったのだが。

Sub シートコピー()
 Dim i As Integer
   For i = 1 To 12
     ’雛形がシート1にあったのだ
     Sheets(1).Copy after:=Sheets(Sheets.Count)
     ActiveSheet.Name = i & "月明細書"
   Next
End Sub
e0080122_1725996.gif

やり方や構文的にはどうあれ、目的のものが出来たので良しとする。
[PR]
by slayer0210 | 2006-02-12 17:04 | マクロ

任意の範囲に写真を挿入する

写真を挿入すると、サイズが大小様々だったり、また貼り付けられる位置も任意の場所には張り付かない。
そんな時の為に便利な(?)マクロを作ってみた。

Sub 任意の範囲に写真を挿入()
 Dim myFname As String
 Dim myrange As Range
 Dim 元図 As Object
   myFname = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")

    If myFname = "False" Then Exit Sub
   On Error GoTo erhand
    Set myrange = Application.InputBox("取り込み範囲をドラッグして下さい", "任意の範囲をドラッグ", Type:=8)
    Set 元図 = ActiveSheet.Pictures.Insert(myFname)
     With 元図
       .Height = myrange.Height
       .Width = myrange.Width
       .Top = myrange.Top
       .Left = myrange.Left
     End With
   Exit Sub
erhand: MsgBox "キャンセルしました"
End Sub
e0080122_1646598.gif

上図のようなダイアログが表示されるので、任意の場所をドラッグして取り込み場所などを入れる。
すると、ドラッグしたサイズと場所に写真が挿入される。
e0080122_16503951.gif

ただ、縦横の比率などは一切無視しているで妙な写真になることは確かだ。
他の人にとっては糞の役にも立ちそうにないが、目的のものが出来たのでよしとする。
[PR]
by slayer0210 | 2006-01-19 16:51 | マクロ

任意の数で写真を分割する

以前に写真を2分割するでも紹介したが、今回は縦横ともに任意の数で写真を分割してくれるマクロを。
例えば、縦2、横3で分割した場合は、下図のようになる。
e0080122_1372513.gif

細かなエラー処理などは施していないが、例により糞の役にも立ちそうにないマクロのためこのまま実行してみる。

Sub 分割()
 Dim 元図 As Object
 Dim 各々図 As Shape

 Dim i As Integer
 Dim j As Integer
 Dim num As Integer
 Dim myFname As String

 'Dim x As Integer, y As Integer
 Dim 元図幅 As Single, 元図高 As Single
 Dim 分割幅 As Single, 分割高 As Single

 Const 隙間 As Integer = 5
 Dim 横分割数 As Integer, 縦分割数 As Integer

  Call mySdel

  myFname = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")
  If myFname = "False" Then Exit Sub
   Set 元図 = ActiveSheet.Pictures.Insert(myFname)
     With 元図
       .Top = 5
       .Left = 5
     End With
  横分割数 = Application.InputBox("横何分割?", "0以外の数値を入力")
  縦分割数 = Application.InputBox("縦何分割?", "0以外の数値を入力")

  元図幅 = 元図.Width
  元図高 = 元図.Height
  分割幅 = 元図幅 / 横分割数
  分割高 = 元図高 / 縦分割数
    元図.Copy
    num = 1

  For i = 1 To 縦分割数
    For j = 1 To 横分割数
      ActiveSheet.Paste
       Selection.Name = "各々図" & num
      With ActiveSheet.Shapes("各々図" & num)
        .Top = 隙間 * i
        .Left = 隙間 * j
        With .PictureFormat
          .CropTop = 分割高 * (i - 1)
          .CropBottom = 分割高 * (縦分割数 - i)
          .CropLeft = 分割幅 * (j - 1)
          .CropRight = 分割幅 * (横分割数 - j)
        End With
     End With
       num = num + 1
    Next
  Next
      元図.Delete
End Sub
上記の構文中に出てくるサブルーチンはあえてここで書く必要もないと思ったので、書かなかった。
また縦、横ともに10ぐらいの数値は大丈夫だがそれ以上になると処理に時間がかかってエクセルが止まってしまう場合がある。
しかし、目的のものが出来たのでよしとする。
[PR]
by slayer0210 | 2006-01-13 13:25 | マクロ

写真を2分割する

以前にトリミングもどきでも紹介したが、今回はシートに写真を挿入し、その写真を2分割してみた。
e0080122_8345186.gif

コード的にはベタベタでもっとスッキリさせる必要もあるが・・・。あまり糞の役にも立ちそうにないのでこのままで実行させた。

Sub 分割()
 Dim mypic As Object, mypic1 As Shape, mypic2 As Shape
 Dim picW As Single, picBW As Single
 Dim myFname As String
  myFname = Application.GetOpenFilename(FileFilter:="すべての図(*.jpg),*.jpg")

   If myFname = "False" Then Exit Sub

   Set mypic = ActiveSheet.Pictures.Insert(myFname)

     picW = mypic.Width
     picBW = mypic.Width / 2

  mypic.Copy
  ActiveSheet.Paste
  Selection.Name = "mypic1"
    Set mypic1 = ActiveSheet.Shapes("mypic1")
     With mypic1.PictureFormat
       .CropRight = picBW
     End With

     With mypic1
       .Top = 20
       .Left = 20
       .IncrementRotation 350
     End With

  ActiveSheet.Paste
  Selection.Name = "mypic2"
    Set mypic2 = ActiveSheet.Shapes("mypic2")
     With mypic2.PictureFormat
       .CropLeft = picBW
     End With

    With mypic2
       .Top = 20
       .Left = 20 + picBW + 10
       .IncrementRotation 10
    End With
      mypic.Delete
    ActiveSheet.Shapes.Range(Array("mypic1", "mypic2")).Group
End Sub

こうしてみると、Withをネストすればよかったが・・・かなりメチャクチャだ。
しかし目的のものが出来たのでよしとする。
e0080122_849619.gif

[PR]
by slayer0210 | 2006-01-12 08:49 | マクロ

シート名の一部を入力すると選択する

シート数が増えてくると、目的のシートを見つけるのが面倒になってくる。
またシート名の一部さえ覚えていれば、そのシートをアクティブにしてくれるマクロを。
e0080122_21405330.gif

Sub シート選択()
 Dim myS As Worksheet
 Dim myF As Boolean
 Dim mystr As String

 myF = True
 mystr = Application.InputBox("シート名の一部を入力して下さい")

  For Each myS In Worksheets
    If myS.Name Like "*" & mystr & "*" Then
      myS.Select (myF)
      myF = False
    End If
 Next
End Sub

また、これは1枚のシートのみならず、該当するシートをすべて選択することができるので
ある意味便利かもしれないが・・・わずらわしいとも・・・微妙だが。

例えば、シート名の中に同一の言葉を含むシートはすべて選択される(下図)
これは『』と入力した際に選択されたシートだ。
e0080122_21453892.gif

[PR]
by slayer0210 | 2006-01-11 21:47 | マクロ

動く文字列

一つのセルの中で動きながら表示される文字列を表現してみた。
街角でみかけるニュースなどの看板みたいなイメージだが・・・

Sub 動く文字列()
 Dim mystr As String
 Dim i As Integer
 Dim i2 As Integer
   mystr = "ニュースのような動く文字列。"

  For i = 1 To Len(mystr)
    With Range("a1")
      .Value = Left(mystr, i)
      .HorizontalAlignment = xlRight
    End With
     Application.Wait (Now() + TimeValue("00:00:01"))
  Next

  For i2 = 1 To Len(mystr)
    With Range("a1")
      .Value = Mid(mystr, i2 + 1, Len(mystr) - i2 + 1) & Left(mystr, i2)
    End With
     Application.Wait (Now() + TimeValue("00:00:01"))
  Next
End Sub
e0080122_10384353.gif

A1セルには予め背景色とフォントの色を設定しておいてから実行してみた。
ちょっと無理やりな気もするが目的のものが出来たのでよしとする。
[PR]
by slayer0210 | 2006-01-10 10:40 | マクロ

マウスを動かすとコンボボックスが選択

ユーザーフォーム上に配置したコンボボックスなどは通常は▼をクリックするとリストが表示される。
もしコンボボックスが何個も存在したら、いちいちクリックするのも面倒くさい。
e0080122_836228.gif


Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  ComboBox1.SetFocus
  ComboBox1.DropDown
End Sub

目的のコンボボックスに上記のようなイベントマクロを記述すればよいようだ。
DropDown メソッドは、コンボ ボックスのリストを下に表示させる場合に使用する。
上図ではテキストボックスも自動的にSetFocusするようにしてみた。
Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  TextBox1.SetFocus
End Sub

SetFocusするとテキストボックス内にカーソルが表示され、即入力できる状態になる。
[PR]
by slayer0210 | 2006-01-10 08:49 | マクロ

シート名を検索

シート数が増えてくると、目的のシートを探すのが面倒だったりする。
そんなときに便利な(かどうかは微妙だか)マクロを。

Sub シートの有無()
 Dim mySname As Variant
  mySname = Application.InputBox("シート名を入力して下さい")

  If mySname = False Then
    MsgBox "キャンセルします"
  Else
   On Error GoTo erhand
     Sheets(mySname).Select
       Exit Sub
erhand: MsgBox "見つかりません"
  End If
End Sub

このマクロを実行すると、下図のようなダイアログが表示され、探したいシート名を入力する。
e0080122_1837053.gif

入力したシートが存在するときは、そのシートをselectするが、見つからない場合は下図の表示が現れるようにした。
もちろん、キャンセルボタンを押したときもそのむねのメッセージが表示される。
e0080122_1840877.gif

この構文でのポイントは、キャンセルボタンを押したときの処理ということだろうか・・・
キャンセルを選択すれば、『False』がもどる。
様々な場合を考えてみて(ちょっとだけ)変数はVariantがエラーが起きなかった。
[PR]
by slayer0210 | 2006-01-08 18:45 | マクロ

任意数だけシートを追加

自分的には非常に便利だと思っているが、よく考えるとあまり役に立たないマクロを。
複数枚シートを追加したい場合などがあると思うが、そんなときに使ってみる。

Sub 任意枚数シートの追加()
 Dim mySnum As Integer
  mySnum = Application.InputBox("枚数を入力", Type:=1)
    If mySnum = False Then
     Exit Sub
    Else
     Worksheets.Add after:=Sheets(Sheets.Count), Count:=mySnum
    End If
End Sub

このマクロを実行すると、下図のようなダイアログが表示されるので、任意数だけ入力すると
その数だけシートが追加される。もっともシート末尾にだが。
シート数100枚ぐらいは大丈夫じゃないかな?試したことはないが・・・
e0080122_17321777.gif

[PR]
by slayer0210 | 2006-01-08 17:33 | マクロ