カテゴリ:マクロ( 42 )

末尾シートの削除

別に末尾シートに限ったことじゃないが、シートを削除するマクロを。
Sheets(Sheets.Count).Delete
基本的にはこの一文で済む話だが、シート削除する際に警告画面がでる。
この画面が面倒くさい場合は、
Sub シート削除()
 Application.DisplayAlerts = False
  Sheets(Sheets.Count).Delete
 Application.DisplayAlerts = True
End Sub

この様にApplication.DisplayAlertsを使用するとよい。
ここでは、Sheetsを使用したが、Worksheetsでも良いと思う。
(SheetsとWorksheetsでは微妙だが・・・)
[PR]
by slayer0210 | 2006-01-08 17:16 | マクロ

年齢計算

年齢や経過年数などを調べるにはDATEDIF関数を使うと便利だ。
この関数は、ダイアログボックスが使用できないのでセルに直接入力となる。

下図の場合は、C2セルに『=DATEDIF(B2,TODAY(),"Y")』と入力する。
これで基本的な年齢は算出される。
しかし図ではそれだけでもアレなので、"歳"や"ヶ月"などオマケでつけてみた。
e0080122_17345651.gif

単位部分もかなり豊富なので目的に応じた引数を入力するとよいかと。
[PR]
by slayer0210 | 2005-12-26 17:36 | マクロ

重複した行を削除する(AdvancedFilter)

以前に重複データ削除でも紹介したが、今回はAdvancedFilterを使ってリストから削除するマクロを。
e0080122_825479.gif

Sub 重複削除()
 Range("a1").CurrentRegion.AdvancedFilter action:=xlFilterCopy, _
 copytorange:=Range("E1"), unique:=True
End Sub

今回は同一シートのE1セルに放出したが、場合に応じて他のシートに表示させてもいいと思う。
ActionxlFilterInPlaceを指定すれば、その位置で実行される。
ここでのポイントはUniqueTrueを指定し重複した行を無視して抽出する点だろうか。
[PR]
by slayer0210 | 2005-12-26 08:35 | マクロ

色に応じて個数を数える(ユーザー定義関数)

例えば下表のように、何色のセルが何個あるのか数えたい場合がある。そんな時の為にユーザー定義の関数を作ってみた。
e0080122_12184232.gif

Function CCOUNTIF(範囲 As Range, 色 As Range) As Integer

Dim myrange As Range
Dim iro As Integer
Dim i As Integer
 iro = 色.Interior.ColorIndex
 i = 0
   For Each myrange In 範囲
     If myrange.Interior.ColorIndex = iro Then
        i = i + 1
     End If
   Next
     CCOUNTIF = i
End Function

セルに直接この関数を入力してもいいが、関数のダイアログを表示させてもいいと。
e0080122_12211847.gif

今回は範囲の部分を絶対参照にしたが、場合に応じて・・・ということで。
また、引数の『色』の部分にはその色が表示されていセルをクリックすればよい。
関数名はCOUNTIFをまねてCCOUNTIFとしてみた。
[PR]
by slayer0210 | 2005-12-22 12:23 | マクロ

塗りつぶされたセル数を数える(ユーザー定義関数)

以前にユーザー定義関数(色合計)赤色の数を数えるでもやってみてはいるが、
今回は指定した範囲内に塗りつぶされたセルの数を数える関数を作ってみた。

Function CCOUNT(範囲 As Range) As Integer
   Dim myrange As Range
   Dim i As Integer
     i = 0
    For Each myrange In 範囲
      If myrange.Interior.ColorIndex <> xlNone Then
        i = i + 1
      End If
    Next
      CCOUNT = i
End Function

コードは出来るだけ簡略化したが、目的の関数が出来たのでよしとしよう。
e0080122_9564711.gif

e0080122_958453.gif

関数名はDCOUNTをまねてCCOUNTとした。
[PR]
by slayer0210 | 2005-12-22 09:59 | マクロ

目次シート作成(イベントマクロ)

以前に目次シートの作成でも紹介したが今回はイベントマクロで目的のシートを選択してみた。
シートには予め「目次シート」というシートを作成しておき、このシートモジュールに下記を記しておく。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  If Target.Column <> 1 Or Target.Value = "" Then
    Exit Sub
  End If
    Sheets(ActiveCell.Value).Activate
End Sub

また、標準モジュールには

Sub 目次リスト作成()
 Dim i As Integer
 Columns(1).Clear
   For i = 1 To Sheets.Count
     Cells(i, 1).Value = Sheets(i).Name
   Next
End Sub
などと記しておき、目次シートに最初から作成していたボタンをクリックすると目次が更新されるようにしてみた。

以前目次シート作成で紹介したマクロはシート名を日付データなどにしていた場合にはリンク機能が上手く働かなかったが、今回は大丈夫だ。
相変わらず雑なコーディングだが目的のものができたので良かった。
e0080122_0313622.gif

e0080122_036115.gif

[PR]
by slayer0210 | 2005-12-22 00:36 | マクロ

他のデータの変更をさせない?

セルをロックして変更をさせない方法があるが、今回はイベントマクロを使ってselectさせない方法を。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Dim myrange As Range
 Set myrange = Application.Intersect(Range("C3:F7"), Selection)

   If myrange Is Nothing Then
     Range("C3").Select
   Else
     myrange.Select
   End If
End Sub
e0080122_0515425.gif

上図のように変更させたくない場所を選択した場合には、許可された範囲のみを選択しなおす。
なにかの折には役に立つかもしれないが・・・
[PR]
by slayer0210 | 2005-12-21 00:55 | マクロ

表を図として貼り付ける(リンクする)

リンクしない図として貼り付けるマクロを、リンクさせてみた。

Sub リンクする図として貼り付け()
  ActiveCell.CurrentRegion.Copy
  ActiveSheet.Pictures.Paste link:=True
  Application.CutCopyMode = False
End Sub
e0080122_095328.gif
上図のように元データを変更すると図も変更された。
[PR]
by slayer0210 | 2005-12-21 00:10 | マクロ

表を図として貼り付ける

以前にカメラ機能でも紹介したが、今回はそれをマクロでやってみた。
元データにリンクはしていないし、ただ単に図として貼り付けているだけの単純なもの。
Shiftキーを押しながら『編集』をクリックすると現れる隠れコマンドのような感じだろうか・・・

Sub 図として貼り付ける()
  ’コピーしたい表の一部をアクティブにしてから実行
  ActiveCell.CurrentRegion.CopyPicture
  ActiveSheet.Pictures.Paste
End Sub

実に簡単だ。こんなことやらなくても素直にカメラ機能や一般機能でやったほうが良かったかも。
e0080122_23551272.gif

[PR]
by slayer0210 | 2005-12-20 23:56 | マクロ

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

昨日任意数で四角(オートシェイプ)を描くでも書いたが、今回は横方向のみではなく縦方向へも作成してみた。

Sub 任意の数でオートシェイプを作る()
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim kosu As Integer 
 kosu = InputBox("作成したい図形の個数を入力", "半角で")

 For y = 1 To Int(kosu / 4) + 1
   For x = 1 To 4
     If i = kosu Then Exit For
       ActiveSheet.Shapes.AddShape(msoShapeRectangle, 20 * x, 20 * y, 20, 20).Select
          i = i + 1
   Next
 Next
End Sub

Sub 削除()
Dim myshape As Shape
 For Each myshape In ActiveSheet.Shapes
    If myshape.Type <> msoFormControl Then
       myshape.Delete
    End If
 Next
End Sub
e0080122_10132784.gif

意味もなくImputBoxを出してはみた。
e0080122_1017113.gif

変数などが少々おかしいと思われるが、目的のものが出来たのでよしとするか。
[PR]
by slayer0210 | 2005-12-10 10:19 | マクロ