項目

セルの貼り付け(ペースト)をする際文字入力等の操作をするとクリップボードがクリアされペースト出来ない

内容説明

セル範囲を選択しコピー＆ペーストをする場合に、コピーしたあと文字入力等の操作をするとクリップボードに記憶されている内容がクリアされペースト出来ません。
Lotus123やWordでは次の内容がクリップボードに記憶されるまでは前回の内容はクリアされません。これがWindowsの標準のインターフェイスです。

Excelで同様にクリップボードの内容を次の内容が記憶されるまで保存しておくマクロを紹介します。
ショートカットメニューに[+切り取り]・[+コピー]・[+貼り付け]・[++貼り付け]が追加されます。
機能として 複数の履歴をカット＆コピー＆ペーストする事が出来ます。もちろんセルの書式を伴う貼り付けを行います。

新規のBookを開きモジュールシートに次のVBAコードをコピーし適当なファイル名で保存します。(ユーザー用マクロのBookがあればそれを使えばよい)

'標準モジュール
Option Explicit
Const dCOPYNUM = 5
Dim dshortcount&, dval$(dCOPYNUM), dnum&, dwb As Workbook

Sub Auto_Open()
  Dim neww&
  If dwb Is Nothing Then
    neww = Application.SheetsInNewWorkbook
    Application.SheetsInNewWorkbook = dCOPYNUM
    Set dwb = Workbooks.Add
    Application.SheetsInNewWorkbook = neww
    Windows(dwb.Name).Visible = False
  End If
  If dshortcount Then Exit Sub
  dshortcount = ShortcutMenus(xlWorksheetCell).MenuItems.Count
  With ShortcutMenus(xlWorksheetCell).MenuItems
    .Add Caption:="-"
    .Add Caption:="+切り取り", OnAction:="k_cut"
    .Add Caption:="+コピー", OnAction:="k_copy"
    .Add Caption:="+貼り付け", OnAction:="k_paste1"
    .Add Caption:="++貼り付け", OnAction:="k_paste2"
  End With
End Sub
Sub Auto_Close()
  Dim ii&
  If Not dwb Is Nothing Then dwb.Close saveChanges:=False
  If dshortcount = 0 Then Exit Sub
  On Error Resume Next
  For ii = 1 To 5
    ShortcutMenus(xlWorksheetCell).MenuItems(dshortcount + 1).Delete
  Next
  On Error GoTo 0
  dshortcount = 0
End Sub

Sub k_cut()
  k_cutcopy 0
End Sub
Sub k_copy()
  k_cutcopy 1
End Sub
Sub k_cutcopy(cc&)
  dnum = dnum - 1
  If dnum < 1 Then dnum = dCOPYNUM
  If cc = 0 Then Selection.Cut Else Selection.Copy
  dval(dnum) = Cells(Selection.Areas(1).Rows.Row, Selection.Areas(1).Columns.Column)
  If dval(dnum) = "" Then dval(dnum) = " "
  With dwb.Sheets(dnum)
    On Error Resume Next
    .ClearContents
    .Range("A1").Select
    .Paste
  End With
  If cc = 0 Then Selection.ClearContents
End Sub
Sub k_paste1()
  k_paste 1
End Sub
Sub k_paste2()
  k_paste 0
End Sub
Sub k_paste(fg&)
  Dim msg$, inp$, ii&, jj&
  If dnum = 0 Then On Error Resume Next: ActiveSheet.Paste: Exit Sub
  If fg = 0 Then
    msg = "　貼り付ける番号を入力して下さい 1〜" & CStr(dCOPYNUM)
    For ii = 1 To dCOPYNUM
      jj = dnum + ii - 1: If jj > dCOPYNUM Then jj = jj - dCOPYNUM
      msg = msg & vbCrLf & ii & ") " & dval(jj)
    Next
    inp = InputBox(msg, "+貼り付け", "1")
    If inp = "" Or Val(inp) < 1 Or Val(inp) > dCOPYNUM Then Exit Sub
    jj = Val(inp) + dnum - 1: If jj > dCOPYNUM Then jj = jj - dCOPYNUM
  Else
    jj = dnum
  End If
  Windows(dwb.Name).Visible = True
  Sheets(jj).Select 
  Selection.Copy
  Windows(dwb.Name).Visible = False
  ActiveSheet.Paste
End Sub

次に以下のようにアドインの作成を行います。
1. モジュールシートで[ツール]-[アドインの作成]を開く。
2. [保存する場所]にExcelのXLStartフォルダを指定し保存します。
   例) C:\MSOffice\Excel\XLStart

次にExcelを起動すれば拡張のショートカットメニューが使えます。
セル範囲を選択し右クリックをすると表示されるショートカットメニューに[+切り取り]・[+コピー]・[+貼り付け]・[++貼り付け]が追加されています。

各項目の機能は次の様です。
[+切り取り]：選択範囲をカットし保存します
[+コピー]　：選択範囲をコピーし保存します
[+貼り付け]：最も新しく[+切り取り]又は[+コピー]した内容をペーストします。
[++貼り付け]：[+切り取り]や[+コピー]の履歴を表示したインプットボックスが開きます。目的の番号を入力し[OK]を押すとペーストします。

履歴を新しいものから５個まで保存するように作っています。

項目

セル範囲のユニークな項目数を返すNUM2関数

内容説明

行や列のセル範囲からユニークな種類の項目数を返すNUM2関数です。 コードを標準モジュールに貼り付けてお使い下さい。


'NUM2関数 選択範囲にユニークな何種類のデータがあるかを返す
' 書式 NUM2(範囲)
'   範囲  :セル範囲
'   戻り値:ﾃﾞｰﾀの種類数
' 使用例 B7に関数 =NUM2(B2:B6) を記述すると 3と表示される
'    A    B    C    D
' --------------------
'1| A列  B列
'2|  1   AAAA
'3|  2   BBBB
'4|  3   CCCC
'5|  4   AAAA
'6|　5　 CCCC
'7|  6   =NUM2(B2:B6)

Function NUM2(rg As Range)
  Dim dic As Object, ele As Variant
  Set dic = CreateObject("Scripting.Dictionary")
  For Each ele In rg.Value
    If ele <> "" Then dic(ele) = dic(ele) + 1
  Next
  NUM2 = dic.Count
End Function

項目

分数(1/2,1/3,3/1000など)を入力する方法

内容説明

Excelで 1/3 と入力すると日付と判断され 1月3日 と表示されます。
分数を意図通りに入力するには頭に0 (半角の数字の0とスペース)を付加し 0 1/3 と入力します。
[セルの書式設定]-[表示形式]タブの分数の項でいくつかの表示形式を選べます。しかし、入力した分数の修正は出来ない、値は整数しか入力できない等々、要するにユーザーの意図した処理が出来ないのである。

色々な分数を扱うには文字列として頭に'を付加し '3.5/1000 と入力するしかないようです。表示位置は[ｾﾙの書式設定]-[配置]タブで右詰めに設定します。
ここで問題になるのが この分数のセルを数値として計算に用いる場合や値を表示する場合です。以下のようなユーザー関数を使うとうまくいきます。

分数文字列の値を返すVAL2関数を示します。コードを標準モジュールに貼り付けお使い下さい。
計算を行うセルには =VAL2(A7)*2 の様に、通常の関数と同じに使えます。(A7 は文字列として分数を入力したセル)


'VAL2 関数
'分数の文字列("1.5/3","3/100"等)の値を返す
'書式　VAL2(分数の文字列)
'  分数の文字列 /の左右に数字がある文字列,帯分数でも良い("2 1/3"等)　
Function VAL2(cc) As Double '分数文字列の値を返す
  Dim ii&, jj&
  ii = InStr(cc, "/")
  If ii = 0 Then VAL2 = Val(cc): Exit Function
  jj = InStr(cc, " ")
  If jj > 1 And jj + 1 < ii Then VAL2 = Val(Left(cc, jj - 1)): jj = jj + 1 Else jj = 1
  VAL2 = VAL2 + Val(Mid(cc, jj, ii - 1)) / Val(Mid(cc, ii + 1))
End Function

項目

シートのセルに変数2次元配列で高速にアクセスする

内容説明

各シートのセルに2次元配列変数で行と列を指定して参照や値の変更が出来たらいいですね。VBAでの計算プログラムがすごく簡単明快になります。
大量データ(数百,数千レコードを計算する場合、各セルに計算式を埋込むと動作が遅くなりファイルサイズも大きくなります。マクロで一気に計算してしまいましょう。

最高速で大量デ−タの計算を行う配列を利用した方法を示します。

'シートのセルに変数2次元配列で最高速でアクセスする
'新規のbookでSheet1,Sheet2を準備しアクティブにしてtestして下さい
Sub E95M007()
  Dim rg1 As Range, rg2 As Range, xx&, yy&
  Dim d1 As Variant, d2 As Variant
  Set rg1 = ActiveWorkbook.Sheets("Sheet1").Range("a1:j1000")
  Set rg2 = ActiveWorkbook.Sheets("Sheet2").Range(rg1.Address)
  d1 = rg1: d2 = rg2 '配列へセル値を代入
  'Setキーワードを用いない場合は次のように記述
  'd1 = ActiveWorkbook.Sheets("Sheet1").Range("a1:j1000").Value
  'd2 = ActiveWorkbook.Sheets("Sheet2").Range("a1:j1000").Value
  'sheet1へtest用データ作成
  For yy = 1 To UBound(d1)      '行のループ
    For xx = 1 To UBound(d1, 2) '列のループ
      d1(yy, xx) = yy + xx - 1
    Next
  Next
  rg1 = d1 '配列からセルへ書戻し
  'Setキーワードを用いない場合は次のように記述
  'ActiveWorkbook.Sheets("Sheet1").Range("a1:j1000").Value = d1
  'sheet2へ2次元配列で計算処理
  For yy = 1 To UBound(d1)      '行のループ
    For xx = 1 To UBound(d1, 2) '列のループ
      d2(yy, xx) = d1(yy, xx) * 10 'ここではセル値の変更は無い
    Next
  Next
  rg2 = d2 '配列からセルへ書戻し
  'Setキーワードを用いない場合は次のように記述
  'ActiveWorkbook.Sheets("Sheet2").Range("a1:j1000").Value = d2
End Sub

次に、少量デ−タの速度を気にしなくてもいい場合の、より簡単に2次元配列変数のように行と列を指定して計算を行う方法を示します。

'Rangeオブジェクトを用いた低速だが簡単な計算例
Sub test2_E95M007()
  Dim va1, va2, xx&, yy& '用いる変数を宣言
  Set va1 = ActiveWorkbook.Sheets("Sheet1").Range("A1")
  Set va2 = ActiveWorkbook.Sheets("Sheet2").Range("B3")
  For yy = 1 To 5   '行のループ
    For xx = 1 To 3 '列のループ
      va1(yy, xx) = yy + xx - 1 '元データの設定
      va2(yy, xx) = va1(yy, xx) * 10 '即セル値が書込まれる
    Next
  Next
End Sub

項目

VBAでExcelのワークシート関数(組込み関数)を使う

内容説明

一例としてMIN,VLOOKUP,ROUND関数などのワークシート関数(組込み関数)をVisual Basic で用いると｢SubまたはFunctionが定義されていません｣とエラーになります。
この原因は それらの関数がVBA関数として存在しないからです。

Visual BasicでExcelのワークシート関数を呼び出すにはApplicationオブジェクトを使います。
ワークシート関数を使うステートメントには ans=Application.Min(range) のように必ずApplication識別子を付けて用います。

Excel2000より WorksheetFunctionオブジェクトが用意されました。
以下VisualBasicヘルプより
VisualBasicではWorksheetFunction オブジェクトを介してExcelワークシート関数を使用できます。

使用例
Sub FindFirst()
  myVar = Application.WorksheetFunction _
    .Match(9, Worksheets(1).Range("A1:A10"), 0)
  MsgBox myVar
End Sub

項目

Selectせず分割ウィンドウ枠を固定する

内容説明

分割ウィンドウ枠を固定するFreezePanesプロパティは通常固定する位置をSelectして実行する必要があります。
Selectせず任意の位置で分割ウィンドウ枠を固定するコードを示します。

'Selectして分割ウィンドウ枠を固定(通常の方法)
Sub teat1_FreezePanes()
  Range("B3").Select
  ActiveWindow.FreezePanes = True
End Sub

'Selectせず分割ウィンドウ枠を固定
'但し、ウィンドウが分割される(SplitプロパティがTrue)
Sub test2_FreezePanes()
  With ActiveWindow
    .SplitColumn = 1
    .SplitRow = 2
    .FreezePanes = True
'Debug.Print .Split
  End With
End Sub

'分割ウィンドウ枠を解除
Sub teat_FreezePanes_False()
  With ActiveWindow
    .FreezePanes = False
    .Split = False
  End With
End Sub

項目

SUMIF関数を拡張したOR又はANDで検索条件を設定出来る SUMIF2関数

内容説明

SUMIF関数は１つの検索条件しか設定出来ません。OR又はANDで２つの検索条件を設定出来るSUMIF2関数です。
以下のコードをモジュールシートにコピーしてお使い下さい。


' SUMIF2 関数
' 指定された検索条件に一致するセルの値を合計する
' SUMIF関数を拡張し OR 又は AND を指定して２つの検索条件を設定できる
' 書式 SUMIF2(範囲, 検索条件, 合計範囲)
' 検索条件は半角の " " で囲む必要があります　"演算子 数値 AND/OR 演算子 数値"
' 演算子(以下の6種類)
'   =  <  >  <=  >=  <>
' 使用例
'   SUMIF2(A1:A4,">1200 and <4500",B1:B4)
'   SUMIF2(A1:A4,"<1200 or >=4500",B1:B4)
Function SUMIF2(aa, b$, cc)
  Dim ii, i1, i2, f1, f2, z$
  For ii = 1 To Len(b$) 'スペース削除 検索条件の文字列のスペース処理
    If Mid(b$, ii, 1) <> " " Then z$ = z$ + Mid(b$, ii, 1)
  Next
  i1 = InStr(1, z$, "and", 1): i2 = 3               'AND
  If i1 = 0 Then i1 = InStr(1, z$, "or", 1): i2 = 2 'OR
  SUMIF2 = 0
  For ii = 1 To aa.Count
    f1 = kConJud(z$, aa(ii))
    If i1 <> 0 Then f2 = kConJud(Mid(z$, i1 + i2), aa(ii))
    If (i2 = 3 And f1 = 1 And f2 = 1) Or (i2 = 2 And (f1 = 1 Or f2 = 1)) Then _
      SUMIF2 = SUMIF2 + cc(ii)
    Next
End Function
Private Function kConJud(s$, dd) '検索条件の判定 1:ok 0:no
  kConJud = 0
  If Left(s$, 1) = "=" And (Mid(s$, 2, 1) = ">" Or Mid(s$, 2, 1) = "<") Then _
    Left(s$, 1) = Mid(s$, 2, 1): Mid(s$, 2, 1) = "="                     '=>,=< を有効に
  If Left(s$, 1) = ">" And Mid(s$, 2, 1) = "<" Then Mid(s$, 1, 2) = "<>" '>< を有効に
  Select Case Left(s$, 1)
  Case "=" '=の処理
    If Val(Mid(s$, 2)) = dd Then kConJud = 1
  Case ">" '>,>=の処理
    Select Case Mid(s$, 2, 1)
    Case "=": If dd >= Val(Mid(s$, 3)) Then kConJud = 1
    Case Else: If dd > Val(Mid(s$, 2)) Then kConJud = 1
    End Select
  Case "<" '<,<=,<>の処理
    Select Case Mid(s$, 2, 1)
    Case "=": If dd <= Val(Mid(s$, 3)) Then kConJud = 1
    Case ">": If dd <> Val(Mid(s$, 3)) Then kConJud = 1
    Case Else: If dd < Val(Mid(s$, 2)) Then kConJud = 1
    End Select
  Case Else ' 他の場合
    kConJud = 1
  End Select
End Function

項目

加重平均を求める AVE2関数

内容説明

帳票の単価計算において加重平均を多用しますが、Excelには加重平均を計算する関数がありません。
式の組合せによって加重平均を求めることはできますが、計算ワークを設ける必要があり面倒です。

VBAで加重平均を求めるユーザー関数を作成しました。以下のコードをモジュールシートにコピーしてお使い下さい。


' AVE2関数　加重平均を求める
' 書式 AVE2(質量の範囲, 単価の範囲, 有効値判定の範囲)
'           連続データなら有効値判定の範囲は省略可
' 使用例
'        A      B      C      D
'   -------------------質量---単価--
' 1 | AAAAA   | zzz1 |  200| 100.00|
' 2 |         | zzz2 |  450| 105.00|
' 3 |         | zzz3 |   50| 108.00|
' 4 |subtotal |      |  700| 103.79|  ← [D4]に単価の加重平均を求める計算
' 5 | BBBBB   | zzz4 |  220| 110.00|       100 * 200 / 700
' 6 |         | zzz5 | 1040|  99.00|     + 105 * 450 / 700
' 7 |subtotal |      | 1260| 100.92|     + 108 *  50 / 700 = 103.79
' 8 |   total |      | 1960| 101.94|     (700 は質量の合計)
' [D4] =AVE2(C1:C3,D1:D3)
' [D7] =AVE2(C5:C6,D5:D6)
' [D8] =AVE2(C1:C6,D1:D6,B1:B6)
Function AVE2(aa, bb, Optional ByVal cc) '加重平均関数
'書式 AVE2(質量の範囲, 単価の範囲, 有効値判定の範囲[省略可])
  Dim ii%, wsum
  wsum = 0: AVE2 = 0
  If aa.Count <> bb.Count Then AVE2 = "#VALUE!": Exit Function '引数不正
  For ii = 1 To aa.Count  '質量の合計wsum
    If IsMissing(cc) Then wsum = wsum + aa(ii) _
    Else If cc(ii) <> "" Then wsum = wsum + aa(ii)
  Next
  For ii = 1 To aa.Count  '加重平均
    If IsMissing(cc) Then AVE2 = AVE2 + aa(ii) * bb(ii) / wsum _
    Else If cc(ii) <> "" Then AVE2 = AVE2 + aa(ii) * bb(ii) / wsum
  Next
End Function

項目

VBA 任意の数の引数を受け取るプロシージャの記述

内容説明

任意の数のパラメータを受け取れるプロシージャ(Sub,Function)の記述例を示します。
任意の数のパラメータを受け取るにはキーワード ParamArrayを用います。
受け取ったパラメータの数を調べるにはUBound 関数を用います。


'任意の数の引数を渡せるプロシージャの記述例
Sub testE95003() 'E95003関数のテスト
  Dim pa
  pa = E95003(1, 2, 3, "a", "b", "c")
  MsgBox pa, , "E95003関数"
  pa = E95003(100, "abc")
  MsgBox pa, , "E95003関数"
End Sub

'E95003関数
Function E95003(ParamArray dat())
  Dim ii&, ss$
  For ii = 0 To UBound(dat)
    ss = ss & dat(ii) & " "
  Next
  E95003 = "パラメータ数=" & (UBound(dat) + 1) & vbCrLf & ss
End Function

'testSum関数
'SUMワークシート関数と同機能のユーザー関数(使い方はSUM関数と全く同じ)
'ParamArrayキーワードの使い方を示すため組込関数は一切使わず記述しています
'セルへの記述例　=testSUM(B2:B4,C5:C6,10+5)
Function testSum(ParamArray Value())
  Dim r1, r2
  For Each r1 In Value
    If TypeOf r1 Is Range Then
      For Each r2 In r1
        testSum = testSum + r2
      Next
    Else
      testSum = testSum + r1
    End If
  Next
End Function

項目

アクティブセルの位置を保存し、他の処理後元の位置に復帰する

内容説明

意図的に他のブックやシートを表示して何らかの処理をした場合、アクティブセル(カーソル)の位置が変わってしまいます。
次に示すコードはアクティブセルの位置を保存し、他の処理後、元の状態に復帰する例です。


Sub E95M001()
  Dim rg As Range 'カーソルの位置を保存する変数
  Set rg = ActiveWindow.RangeSelection
  '''''''''''
  '本来の処理
  '''''''''''
  '元の位置に戻す
  rg.Parent.Parent.Activate
  rg.Parent.Select
  rg.Select
End Sub