書式ごとコピーするユーザー定義関数をつくりたい

質問

VBA初心者です。
ExcelにてVBAを使用し、書式ごとコピーができるユーザー定義関数の作成を考えております。
理想としては例えば、A1に

=GetTxt(INDIRECT("G"&B1))

と入力すれば、B1の値に応じてG列の任意の行のセルを引数として指定でき、
指定先のセルを書式ごとA1にコピーできるGetTxt()関数を定義したいのですが、
具体的にどのようにFunctionプロージャを記述すればいいでしょうか？
（コピー元のセルをB1に入力する値に応じて随時自動で変えたいと考えております）

単純に値を返すだけのVBAコードならわかるのですが、
ワークシート上で関数として使用でき、かつ書式なども指定する方法がわかりません。

もしワークシート上での関数としての実行が困難であれば代替案でも構いませんので、
宜しければ何卒ご教示お願い申し上げます。

回答No.1

celena · ベストアンサー

中身だけでよいのならば、引数に渡す形にして、
--------------------
Function GetTxt(cl As String, ro As Long)
GetTxt = Range(cl & ro)
End Function
--------------------
で良いと思います。「=GetTxt("G", B1)」てな使い方です。

関数は値を変更するためのものですから、書式までやりたいとなると関数では出来ないでしょう。（というか無理矢理出来たとしてもやらない方が良い。）

最終的にGetTxt関数をどのような形でシート上にちりばめたいのかにもよりますが、
書式までやりたいのであれば、やはり関数ではなく、VBAのSubプロシージャとして実行するしかないのではと思います。

こちらのプロシージャでセルの丸ごとコピーが出来ますので、それを別のプロシージャから呼ぶ形にしてはいかがでしょうか。
--------------------
Sub copyCell(cl As String, ro As Long, targetCol As Long, targetRow As Long)
Sheet1.Range(cl & ro).Copy
Sheet1.Cells(targetRow, targetCol).PasteSpecial (xlPasteAll)
End Sub

お礼

色々勉強させていただきましたが、目的を達成する手段（コード）が極めてシンプルであったこと、実際にカスタマイズしてシートに散りばめていく上での相性が良かったことの2点から、こちらの回答をベストアンサーとさせていただきました。
皆様、この度は回答誠にありがとうございました。

回答No.4

real beatin（@realbeatin）

' ' ＝＝＝　以下、標準モジュール　＝＝＝　ReW9087799

Option Explicit

' ' /// セル範囲またはセル参照文字列を引数にして、参照元の値を返すだけの単純なＵＤＦ
' ' /// 再計算確定後にThisWorkbookモジュール側で参照元の書式をコピーする為の呼び出し〓が１行
Public Function GetTxt(ByVal vRef As Variant)
　　Application.Volatile False
　　With Application.ThisCell
　　　　On Error GoTo ErrRef_
　　　　If TypeName(vRef) = "String" Then
　　　　　　If InStr(vRef, "!") Or ActiveSheet Is .Worksheet Then
　　　　　　　　Set vRef = Range(vRef)
　　　　　　Else
　　　　　　　　Set vRef = Range("'" & .Worksheet.Name & "'!" & vRef)
　　　　　　End If
　　　　End If
　　　　GetTxt = vRef.Value
　　　　On Error GoTo 0
Call_Out_:
　　　　Call ThisWorkbook.SetSrcDst(rSrc:=vRef, rDst:=.Cells)　'　〓
　　End With
Exit Function
ErrRef_:
　　Set vRef = Nothing
　　GetTxt = CVErr(xlErrRef)
　　Resume Call_Out_
End Function

' ' ＝＝＝　以上、標準モジュール　＝＝＝

' ' ＝＝＝　以下、ThisWorkbookモジュール　＝＝＝　ReW9087799

' ' /// 宣言部
Option Explicit

Private WithEvents appThisXl As Application
Private colSrcDst As New Collection

' ' /// イベント　このブックが開かれたタイミングでApplicationのイベントを活性化
Private Sub Workbook_Open()
　　Set appThisXl = Application
End Sub

' ' /// イベント　Excel.Application の ひとつのセル操作契機に因る一連の再計算すべて が 確定したタイミング
' ' /// Collectionオブジェクトに記録した転写元・転写先間で書式のコピーを実行
Private Sub appThisXl_AfterCalculate()
Dim col As Collection
Dim vAry
　　If colSrcDst.Count = 0 Then Exit Sub
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　End With
　　For Each col In colSrcDst
　　　　Call RangesToAreas(col)
　　　　For Each vAry In col
　　　　　　Call TranscrFormats(vAry)
　　　　Next
　　Next
　　Set colSrcDst = New Collection
　　With Application
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
End Sub

' ' /// 書式転写元／先が同じもの単位で、バラバラのセルをひとつのセル領域に纏める
' ' /// 呼び出し元：ThiswWorkbook／Sub appThisXl_AfterCalculate
Private Sub RangesToAreas(ByRef col As Collection)
Dim vAry
Dim sRefPtn As String
Dim i As Long
　　For i = col.Count To 1 Step -1
　　　　vAry = col(i)
　　　　If vAry(0) Is Nothing Then
　　　　　　sRefPtn = "ErrRef"
　　　　　　If vAry(1).HasArray Then Set vAry(1) = vAry(1).CurrentArray
　　　　　　On Error Resume Next
　　　　　　If Not IsArray(col(sRefPtn)) Then
　　　　　　Else
　　　　　　　　Set vAry(1) = Application.Union(col(sRefPtn)(1), vAry(1))
　　　　　　　　col.Remove sRefPtn
　　　　　　End If
　　　　Else
　　　　　　sRefPtn = vAry(0).Worksheet.Name & "!"
　　　　　　sRefPtn = sRefPtn & Application.ConvertFormula(vAry(0).Address(0, 0), xlA1, xlR1C1, xlRelative, Range(vAry(1).Address(0, 0)))
　　　　　　If vAry(1).HasArray Then
　　　　　　　　Set vAry(1) = vAry(1).CurrentArray
　　　　　　ElseIf vAry(0).Count > 1 Then
　　　　　　　　Set vAry(0) = vAry(0)(1)
　　　　　　End If
　　　　　　On Error Resume Next
　　　　　　If Not IsArray(col(sRefPtn)) Then
　　　　　　Else
　　　　　　　　Set vAry(0) = Application.Union(col(sRefPtn)(0), vAry(0))
　　　　　　　　Set vAry(1) = Application.Union(col(sRefPtn)(1), vAry(1))
　　　　　　　　col.Remove sRefPtn
　　　　　　End If
　　　　End If
　　　　On Error GoTo 0
　　　　col.Add Item:=vAry, Key:=sRefPtn, After:=i
　　　　col.Remove i
　　Next i
End Sub

' ' /// 書式転写
' ' /// 呼び出し元：ThiswWorkbook／Sub appThisXl_AfterCalculate
Private Sub TranscrFormats(ByVal vAry As Variant)
Dim i As Long
　　If vAry(0) Is Nothing Then
　　　　vAry(1).ClearFormats
　　Else
　　　　For i = 1 To vAry(1).Areas.Count
　　　　　　vAry(0).Areas(i).Copy
　　　　　　vAry(1).Areas(i).PasteSpecial Paste:=xlPasteFormats
　　　　Next i
　　　　Application.CutCopyMode = 0
　　End If
End Sub

' ' /// 書式転写[元／先] を 書式転写先シート単位で Collectionオブジェクトに格納（記録）
' ' /// 呼び出し元：Module1／Function GetTxt
Public Sub SetSrcDst(ByVal rSrc As Range, ByVal rDst As Range)
Dim sWksDst As String
　　If appThisXl Is Nothing Then Set appThisXl = Application
　　If Not rSrc Is Nothing Then
　　　　With rSrc.Worksheet
　　　　　　sWksDst = .Parent.Name & "$" & .Name
　　　　End With
　　End If
　　With rDst.Worksheet
　　　　sWksDst = sWksDst & "->" & .Parent.Name & "$" & .Name
　　End With
　　On Error Resume Next
　　If Not IsObject(colSrcDst(sWksDst)) Then
　　　　colSrcDst.Add Item:=New Collection, Key:=sWksDst
　　End If
　　On Error GoTo 0
　　colSrcDst(sWksDst).Add Item:=VBA.Array(rSrc, rDst), Key:=rDst.Address(0, 0)
End Sub

' ' ＝＝＝　以上、ThisWorkbookモジュール　＝＝＝

回答No.3

real beatin（@realbeatin）

こんにちは。

□ＵＤＦ（ユーザー定義関数）は値を返す関数として機能させ、
　書式のコピーについては、ＵＤＦの実行とは切り離して、
　イベントプロシージャで処理する□
という内容でこちらが書いたものを次の投稿にて紹介します。
標準モジュールのＵＤＦは書式を操作しない単機能なものです。
ThisWorkbookモジュール側で、シートやブック等の再計算がすべて済んだタイミングで、
ＵＤＦの参照元から参照先へ書式のコピーを実現させるものです。

まずは、ご質問への直接の応答から。

///

ＶＢＡのＵＤＦで出来る事として、数式を設定したセルに対しは、
値を返すこと、だけです。
セル値以外の設定（プロパティ）を取得・設定することは概ね制限されていますし、
.Copy等のメソッドも動作は保証されないと考えて下さい。
●書式ごとコピーができるユーザー定義関数　は　ExcelやＶＢＡでは不可能●
というのが、普通の応えになります。

●ＵＤＦとExcelの揮発性関数の併用は避けた方がトラブルが少なくなります●
INDIRECT()、OFFSET()、RAND()、NOW()、TODAY()、CELL()、INFO()、などが揮発性関数です。
通常の関数の自動再計算は引数に指定した参照元の変動に連動して行われますが、
揮発性関数の場合は再計算の契機が不規則です。
（セルの挿入・削除・非表示・再表示、定義名操作、シート名前変更、シート位置変更、等々）
ＵＤＦの処理内容と周辺の状況によっては、無限ループにもなりかねません。
揮発性関数で得られる機能は、
ＶＢＡに用意された関数やプロパティで代用することをお奨めします。
（どうしても必要で、セル参照をシート上の関数でやる場合は、
　まだしもINDEX()関数を使う方が、余計なトラブルを減らせます。）
セル参照に纏わる処理などはＵＤＦだけで完結するようなものを
なるべくシンプルに作成するようにして、
Excelの関数との併用は応用的な使用だけに限った方がよいでしょう。
例えば、
> =GetTxt(INDIRECT("G"&B1))
という数式（揮発性関数）を前提にするとＵＤＦは非常にナーバスなものになり、
対策も難しくなります。
　　=GetTxt("G"&B1)
のように引数を指定して、
ＵＤＦ側でRange(引数)みたいにセル範囲を指定するような形で書けばいいです。

私が試した数式例は上記の他に
・適当な単セルに
　　=GetTxt("Sheet1!G"&B1)
　　=COUNTA(GetTxt(G1:G10))
　　　普通に確定。
・２列の範囲を適当な行数選択してから
　　=GetTxt(INDEX($G:$H,$B1,COLUMN(B1000)))
　　　Ctrl+Enterで確定。
・参照元のサイズに合わせた範囲（この場合は10行1列）を選択してから
　　=GetTxt($G$1:$G$10)
　　　Ctrl+Shift+Enterで確定。→ＣＳＥ（配列）数式。
　　　複数セル範囲を同じ大きさ同じ並びで参照する場合は
　　　Excel2007以降では、配列数式で確定した方が計算が省けて軽くなります。
・適当な単セルに
　　=GetTxt("E")
　　　普通に確定。→わざと参照エラーを返して実行結果を確認。
などです。

もしも再計算を[手動]で設定するような場合は、
●[保存前に再計算]オプションを外して、ＵＤＦ由来のトラブルを回避します●

ＶＢＡの編集後の上書き保存前の状態や、各種実行時エラーの後では、
ＵＤＦそのものが不正な結果を返すことがあります。
●ＵＤＦは必要に応じてブックを保存してから再計算させるようにして無駄なエラーを回避します●
ワークシート上でのショートカットキー
Ctrl + Alt + F9 キー や、Shift + Ctrl + Alt + F9 キー 等を使い分けを覚えて、
手動での一括再計算の必要にも備えておいた方がいいでしょう。
●万一に備えて復旧方法を確認しておきましょう●

///

お求めの内容と最終仕様確定に向けたお話。

///

> ... 書式ごとコピー ...
と書いてありますので、Excelの一般機能から、貼付けのオプションで[書式]を選択
した場合の例で今回はお応えしています。
ＶＢＡでもExcelの[書式]貼付けを実行しますので、
シート上の選択範囲が貼付け先に遷移してしまいます。
実行（再計算）前の選択範囲に戻すことは可能ですし、
実際に書いて稼動させてはみましたが、記述が煩雑になり、
掲載文字数の問題もあるので割愛しました。
検討した方がいいのは、コピーする必要があるのは何か？
という点で具体的に絞っていった方が、コピー以外の方法を選べる分、
パフォーマンス、メンテナンスの面で有利になる、という点です。
例えば、フォント色、フォントサイズ、背景色、罫線、など、
それぞれのプロパティ操作で対応した方が、扱い易いものになりますし、
選択範囲の遷移も起こりません。
或いは、[書式]貼付けではトレース出来ないものを転写したい、という場合もあるでしょう。
今回提示するＶＢＡでは、"書式ごとコピー"する処理の部分だけ、
サブプロシージャ（Sub TranscrFormats）に纏めていますので、
何をコピーするのか具体的・限定的に決めることができたら、
この部分だけ書き換えて貰えればいいようにしています。

> 理想としては例えば、A1に
> =GetTxt(INDIRECT("G"&B1))
A1:　　=GetTxt("G"&B1)
A1セルの数式の参照元がB1、と、右向きに参照するのは、
バージョンによっても細かく違いますが、概ね、
再計算を遅くする誘因になる場合もあるので、
こういう設計でお使いになるのなら、数式確定後に
Shift + Ctrl + Alt + F9 キー で一旦すべてを再計算させておくと、
以後ＵＤＦを含むすべての数式の再計算がより安定的に遅くなり難くなります。
シート設計で対応可能ならば、左から右、上から下、という方向で、
参照依存を整える（シートを跨ぐ場合は別）のが関数（ＵＤＦ）を扱う上でベターです。

> （コピー元のセルをB1に入力する値に応じて随時自動で変えたいと考えております）

B1の値に対応したテーブルデータを書式情報と共に表示したい、という理解でいます。
テーブルがある程度固定的で、書式情報を限定できる場合ならば、ＵＤＦの代りに、
　　=INDEX(G:G,B1)
という普通の数式にして、B1を参照した条件付き書式との組み合わせで
済ませられる場合もあると思いますが、可能性があるのなら、
より簡単に済ませられますから、検討・確認してみるといいかも、です。

提示するＶＢＡのスクリプトは、次の投稿がすべてですが、
処理内容が同じものに、動作確認用の記述（★）を追記して、
処理したセル範囲をイミディエイトウィンドウ（Ctrl+G）で確認できるようにした
'デバッグ版'を以下、添えておきます。
Private Sub appThisXl_AfterCalculate()をまるごと差し替えて、試してみると、
ＵＤＦが再計算される契機が各数式ごとに違うことが確認できると思いますので、
仕様確定への資料にしてください。
尚、実際には何も再計算されない筈なのに_AfterCalculateのトリガに掛かる場合が
結構現れると思いますが、すぐにExit Subするように書いてありますので問題ありません。

何かしら不足・不明があれば補足ください。

' ' ///
Private Sub appThisXl_AfterCalculate()　'　 'デバッグ版'
Dim col As Collection
Dim vAry
Dim cn As Long　'　★動作確認用
Debug.Print "▼AppCalculated▼"　'　★
If colSrcDst.Count = 0 Then Exit Sub
With Application
　　.ScreenUpdating = False
　　.EnableEvents = False
End With
For Each col In colSrcDst
　　Call RangesToAreas(col)
　　For Each vAry In col
If vAry(0) Is Nothing Then　'　★
Debug.Print "■ErrRef"; '　★
Else '　★
Debug.Print "■"; vAry(0).Worksheet.Name & "!" & vAry(0).Address(0, 0); '　★
End If '　★
Debug.Print " -> "; vAry(1).Worksheet.Name & "!" & vAry(1).Address(0, 0)　'　★
cn = cn + vAry(1).Count　'　★
　　　　Call TranscrFormats(vAry)
　　Next
Next
Set colSrcDst = New Collection
With Application
　　.EnableEvents = True
　　.ScreenUpdating = True
End With
Debug.Print "▲書式転写", cn; "Cells" '　★
cn = 0　'　★
End Sub
' ' ///

回答No.2

m_and_dmp

関数では、つぎのコードで可能ですが、B1 の値を変更しても、自動的に計算しなおしてくれないようです。（数式バーをクリックしてエンターすると、再計算する。）
－－－－－－－－－－－－－－－－－－－
Function GT()
Dim RN As Integer
RN = Range("B1").Value
Cells(RN, 7).Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
GT = Cells(RN, 7).Value
End Function
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

B1の値を変更した時自動計算するように、イベントプロシージャにしてみました。
B1以外の値が変更された時はなにもしないようになっています。
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RN As Integer, CN As Integer
RN = Target.Row
CN = Target.Column
If RN <> 1 Then GoTo ep
If CN <> 2 Then GoTo ep
RN = Range("B1").Value
Cells(RN, 7).Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ep:
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

「洗練されたコードにする」とかいったことは何もしておりません。ただ「動く」というだけです。