2010-07-28

昨日の自分へ。挿入でも駄目でした＾＾
解決策は二つ。

その１: 範囲をセル単位でなく、行・列単位で指定してコピーペーストするとコピー先のセルの幅や高さもコピー元に合わせてくれるからか、オブジェクトのサイズが変わらない。
その２: 真横や真下以外の場所に複製する場合は、先にコピー先のセルのサイズをコピー元のサイズに合わせてからペーストする。

オブジェクトのサイズ変更しないオプションが、セルごとのコピーペーストには反映しないということを覚えておこう。

追記

件のマクロでセル範囲をコピーしている部分を見たら、コピーした後にセルのサイズをコピー元に合わせてリサイズしていた。もしかすると、オブジェクトのプロパティをいっそ「セルに合わせて移動やサイズ変更をする(S)」にしておけばいいんじゃあ……
と思ってプロパティを変更したら、希望通りコピー元にあるオブジェクトのサイズで複製された。（実際はサイズがセルに合わせて二回変化しているが）
なんだ、かたくなにサイズ変更しないプロパティに拘ってたのがいけないのか…移動＆サイズ変更するにしておくとセル範囲を削除した時にオブジェクトも消えてくれるので、その設定にしておいた方がいいね。
はあ、つかれた。

例によって、ものすごく簡単だけど毎回類似コード書いてるのがばかばかしくなった断片をコピペ。

'-----------------------------------------------------------------------
'  RangeStr
' 行と列を数値で指定すると"A1:B2"みたいな文字列を返すVBA関数
'
' * 2022/04/14 関数の引数にByValつけた
'
'-----------------------------------------------------------------------
Option Explicit


'-----------------------------------------------------------------------
' row,col から、A1 形式の文字列を返す
' r1,c1:開始セル位置 r2,c2:終了セル位置
' f:""じゃなかったら絶対指定にする
' sh:シート or シート名称
Public Function RangeStr(ByVal row1 As Variant, ByVal col1 As Variant, _
    Optional ByVal row2 As Variant = 0, Optional ByVal col2 As Variant = 0, _
    Optional ByVal flg As Variant = "", Optional ByVal sh As Variant = "") As String
    
    Dim rmax As Long
    Dim cmax As Long
    Dim cn1 As String
    Dim cn2 As String
    
    If CInt(Application.Version) > 11 Then
        rmax = 1048576 ' 2007～ の最大行
        cmax = 16384 ' 2007～ の最大列
    Else
        rmax = 65536 ' ～2003 の最大行
        cmax = 256 ' ～2003 の最大列
    End If
    
    If flg <> "" Then flg = "$"
    row1 = VarIntCheck(row1)
    row2 = VarIntCheck(row2)
    col1 = VarIntCheck(col1)
    col2 = VarIntCheck(col2)
    
    If row1 > rmax Or row1 < 1 Or col1 > cmax Or col1 < 1 Then
        RangeStr = ""
        Exit Function
    End If
    
   
    cn1 = ColStr(col1)
    cn2 = ColStr(col2)
    RangeStr = SheetNameStr(sh) & flg & cn1 & flg & CStr(row1)
    
    If row2 > 0 And row2 < rmax And col2 > 0 And col2 < cmax Then
        RangeStr = RangeStr & ":" & flg & cn2 & flg & CStr(row2)
    End If

End Function

'-----------------------------------------------------------------------
' 複数列の文字列 "A:B"とか
Public Function ColsStr(ByVal col1 As Variant, Optional ByVal col2 As Variant = 0, _
        Optional ByVal flg As Variant = "", Optional ByVal sh As Variant = "") As String
    
    If flg <> "" Then flg = "$"
    col1 = VarIntCheck(col1)
    col2 = VarIntCheck(col2)
    
    If col1 > 0 Then
        ColsStr = SheetNameStr(sh) & flg & ColStr(col1)
        If col2 > 0 Then ColsStr = ColsStr & ":" & flg & ColStr(col2)
    End If

End Function

'-----------------------------------------------------------------------
' 複数行の文字列 "1:3"とか
Public Function RowsStr(ByVal row1 As Variant, Optional ByVal row2 As Variant = 0, _
        Optional ByVal flg As Variant = "", Optional ByVal sh As Variant = "") As String
    
    If flg <> "" Then flg = "$"
    row1 = VarIntCheck(row1)
    row2 = VarIntCheck(row2)
    
    If row1 > 0 Then
        RowsStr = SheetNameStr(sh) & flg & Format(row1)
        If row2 > 0 Then RowsStr = RowsStr & ":" & flg & Format(row2)
    End If

End Function

'-----------------------------------------------------------------------
' 選択した行を表す文字列を返す
' "シート名!$A$1:$B$5" みたいなの
Public Function SelectionRangeStr() As String
    Dim rng As Range
    Dim sh As Worksheet ' 選択してるシート
    Dim rs As Long  ' 選択エリアの最初の行
    Dim re As Long  ' 選択エリアの最後の行
    Dim cs As Long  ' 選択エリアの最初の列
    Dim ce As Long  ' 選択エリアの最後の列
    
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        rs = rng.Row
        re = rs + rng.Rows.Count - 1
        cs = rng.Column
        ce = cs + rng.Columns.Count - 1
        SelectionRangeStr = RangeStr(rs, cs, re, ce, "$", rng.Worksheet.Name)
    Else
        SelectionRangeStr = ""
    End If

End Function

'-----------------------------------------------------------------------
' 選択した行を表す文字列を返す
' "シート名!$1:$2" みたいなの
Public Function SelectionRowsStr() As String
    Dim rng As Range
    Dim sh As Worksheet ' 選択してるシート
    Dim rs As Long  ' 選択エリアの最初の行
    Dim re As Long  ' 選択エリアの最後の行
    
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        rs = rng.Row
        re = rs + rng.Rows.Count - 1
        SelectionRowsStr = RowsStr(rs, re, "$", rng.Worksheet.Name)
    Else
        SelectionRowsStr = ""
    End If

End Function

'-----------------------------------------------------------------------
' 選択した列を表す文字列を返す
' "シート名!$A:$B" みたいなの
Public Function SelectionColsStr() As String
    Dim rng As Range
    Dim sh As Worksheet ' 選択してるシート
    Dim cs As Long  ' 選択エリアの最初の列
    Dim ce As Long  ' 選択エリアの最後の列
    
    If TypeName(Selection) = "Range" Then
        Set rng = Selection
        cs = rng.Column
        ce = cs + rng.Columns.Count - 1
        SelectionColsStr = ColsStr(cs, ce, "$", rng.Worksheet.Name)
    Else
        SelectionColsStr = ""
    End If

End Function

'-----------------------------------------------------------------------
' 選択範囲を表す文字列が示す範囲を選択する
' "シート名!$A:$B" みたいなの
Public Sub Select_Range(ByVal rngtxt As String)
    Dim sstr, rstr, pos, ch
    pos = InStr(rngtxt, "!")
    If pos > 0 Then
        sstr = Left(rngtxt, pos - 1)
        ' シート名の前後に''がついてた場合の対処
        ch = Left(sstr, 1)
        If ch = "'" Then sstr = Right(sstr, Len(sstr) - 1)
        ch = Right(sstr, 1)
        If ch = "'" Then sstr = Left(sstr, Len(sstr) - 1)
        rstr = Right(rngtxt, Len(rngtxt) - pos)
        ActiveWorkbook.Worksheets(sstr).Activate
    Else
        sstr = ""
        rstr = rngtxt
    End If
    'MsgBox "Text = " & rngtxt & " Sheet = " & sstr & " Range = " & rstr
    ActiveSheet.Range(rstr).Select

End Sub

'-----------------------------------------------------------------------
' 文字列から列番号を返す
Public Function StrCol(ByVal ctxt As String) As Long
    Dim tlen As Long
    Dim i As Long
    Dim clmno As Long
    Dim chrno As Long
    
    ctxt = StrConv(ctxt, vbUpperCase)
    tlen = Len(ctxt)
    clmno = 0
    If tlen > 0 Then
        For i = 0 To (tlen - 1)
            chrno = Asc(Mid(ctxt, tlen - i, 1)) - &H40
            clmno = clmno + ((26 ^ i) * chrno)
        Next i
    End If
    StrCol = clmno
End Function

'-----------------------------------------------------------------------
' 列数から文字列を返す(A～ZZZ)
Public Function ColStr(ByVal ColumnNumber As Variant) As String
    Dim clmno As Variant
    Dim ctxt As String
    Dim c1 As Long
    Dim c2 As Long
    Dim MAX As Long
        
    MAX = 26
    clmno = VarIntCheck(ColumnNumber)
    ctxt = ""
    
        
    Do While clmno > 0
        c1 = clmno Mod MAX
        If c1 = 0 Then
            c2 = (clmno / MAX) - 1 'よもやデフォルトが四捨五入だとは…
            ctxt = Chr(&H40 + MAX) & ctxt
        Else
            c2 = (clmno - c1) / MAX
            ctxt = Chr(&H40 + c1) & ctxt
        End If
        clmno = c2
    Loop
    
    ColStr = ctxt

End Function

'-----------------------------------------------------------------------
' シート名文字列をRangeStr用に加工
Public Function SheetNameStr(ByVal sh As Variant) As String
    Dim shname As String

    If IsNull(sh) Then
        shname = ""
    ElseIf TypeName(sh) = "Worksheet" Then
        shname = sh.Name
    Else
        shname = CStr(sh)
    End If

    If shname <> "" Then
        If InStr(shname, " ") Then shname = "'" & shname & "'"
        SheetNameStr = shname & "!"
    Else
        SheetNameStr = ""
    End If

End Function

'-----------------------------------------------------------------------
' Variant変数の中を確認して整数に変換する
Public Function VarIntCheck(ByVal vi As Variant) As Long
    If IsNumeric(vi) Then
        VarIntCheck = CLng(vi)
    Else
        VarIntCheck = 0
    End If
End Function

修正履歴

2008/08/02: 引数のデフォルトと判定式を修正。cells指定で0はありえんかった。
2011/02/10: 27以上の数字(AA〜以降)を列に指定する事を全然考えてなかった部分を修正。案外面倒くさかった。
2012/05/08: 行だけとか列だけの指定ができるように修正
2015/05/27: 再帰使えよ＞過去の自分
2016/09/23: RefEditは空白を含むシート名を''でくくるらしいので、同じようにしてみた。あと、文字列から範囲選択する関数とか追加。
2016/12/07: 列とか行とかVBAのIntegerじゃオーバーフローするのに今更気がついた。
2016/12/09: 変数名とか宣言とかちょっとわかりやすくしつつ、外部から呼び出す関数は引数をVariantにして内部でLongなどに変換するようにした＆先日追加した「今選択してる範囲を文字列にする関数」がテストしてなかったら案の定間違えてたので直した。
2022/4/16: 関数の引数にByValつけた。後この数年の間に他にもいろいろ修正したらしいが記録が残ってないそろそろちゃんとバージョン管理すべきか

にっきダイアリー

はてなダイアリーからはてなblogに移動してみました。

Excel2007でオブジェクトを含むセル範囲をコピーしたとき、コピー先のセルサイズによってオブジェクトのサイズが変化してしまう問題の解決

追記

ひさびさに日記書いてて気がついた

行と列を数値で指定すると"A1:B2"みたいな文字列を返すVBA関数

修正履歴