[[20120531104000]]　『あるセル範囲で最左,最右に入力のあるセル番地をメx（しんぽん）　ページの最後に飛ぶ

『あるセル範囲で最左,最右に入力のあるセル番地をマクロで取得したい』（しんぽん）

　マクロの初心者です。レベルの低い質問で誠に申し訳ございません。
例えば、A1からZ1のセル範囲で一番左に入力(文字列や数字)されているセルがC1、
一番右に入力されているセルがQ1とすると、マクロでその番地数(Cであれば3、
Qであれば17)を取得したいのですがどのようにしたらよいでしょうか？

　また、この入力データが文字列でなくオートシェイプのときはどのように
番地数を取得したらよいのでしょうか？

　よろしくお願いいたします。

エクセル2002、WinXPです。

（しんぽん）

 前半もセルには、AA1以降にもデータがある場合もあるという仮定も成り立つならば、

 Sub test()
    Dim rng As Range
    Dim rng1 As Range
    Dim 最右 As Range
    Dim 最左 As Range
    On Error Resume Next
    With Range("a1:z1")
       Set rng = .SpecialCells(xlCellTypeConstants)
       If Err.Number = 0 Then
          Set 最左 = rng.Cells(1)
          Set rng1 = rng.Areas(rng.Areas.Count)
          Set 最右 = rng1.Cells(rng1.Count)
          MsgBox 最右.Column
          MsgBox 最左.Column
       Else
          MsgBox "セル範囲にデータがありません"
       End If
    End With
    Set rng = Nothing
    Set rng1 = Nothing
    Set 最右 = Nothing
    Set 最左 = Nothing
 End Sub

 一例です。

 >オートシェイプのときは

 これは、もう少し仕様を詳しく記述してください。

 Shapesコレクションから一つ一つ図形を調べていって、右端の図形、左端の図形を調べなければ
 ならないかもしれません。

 その場合は

 dim shp as shape

 for each shp in activesheet.shapes
    msgbox "名前: " & shp.name & "位置 left : " & shp.left
 next

 このleftプロパティが、最小が最左、最大が最右図形となりますが・・・。

 その比較のアルゴリズムを　For～Next内に記述することになります。

 これは、考えてみてください

 ichinose

とてもエクセレントなマクロの例をいただき誠にありがとうございました。私はDO-LOOPでひとつひとつのセルを判定させる方法で考えていたのですが、今回教えていただき大変参考になりました。オートシェイプは直線や矢印の処理を検討しており、その直線や矢印の引いてある最左セルから最右セルまでのレンジをコピーして他のシートに貼り付けしたいと考えています。いただいたヒントをもとに考えてみます。

 >直線や矢印の処理を検討しており、その直線や矢印の引いてある最左セルから最右セルまでのレンジをコピー

 そういうことですか？

 新規ブックにて、以下のコードを実行し、結果から考察してみてください。

 Sub test()
    Dim lm As Shape
    With ActiveSheet
       .DrawingObjects.Delete
       Set lm = .Shapes.AddLine(165, 7.5, 375.75, 7.5)
       lm.Line.EndArrowheadStyle = msoArrowheadTriangle
       lm.Line.EndArrowheadLength = msoArrowheadLengthMedium
       lm.Line.EndArrowheadWidth = msoArrowheadWidthMedium
       DoEvents: DoEvents
       MsgBox "作成された線のあるセル範囲は・・・・"
       MsgBox .Range(lm.TopLeftCell, lm.BottomRightCell).Address
    End With
 End Sub

 ichinose

ichinose様

　さらなるご教授をいただきありがとうございます。現在試行錯誤でマクロを作成しているの
ですが、うまくいきません・・・　追加で質問させていただいてよろしいでしょうか？
　シートAとシートBがあり、シートBのあるセル範囲で始点から最右セルまでコピーする場合と
最左から終端までをコピーする場合があり、そのコピーしたデータ(文字,数字,矢印,直線)は、
シートAのあるセル範囲に貼り付けしようとしています。そのときにシートAのあるセル範囲に、
別のデータ(矢印や直線)が残っていた場合、データが重なってしまうので、先に貼り付け先の
データは削除する必要があります。そこでこれまで教えていただいたマクロを参考に以下の
ようなマクロ(一部を抜粋)で処理したいのですがうまくいきません(貼り付け先のデータ削除は
できるが、シートBのデータのコピペができない）何が悪いのでしょうか？

Private Sub CommandButton1_Click()

'オートシェープの判定(セル範囲取得)はまだ織り込んでいません
'一日目に登録データがあるか判定
'登録データがある場合,登録シート一日目の開始セル番地取得(最左から終端セルをコピーの場合)

Worksheets("B").Activate

Dim rng As Range
Dim rng1 As Range
Dim 最右 As Range
Dim 最左 As Range
On Error Resume Next
With Range("I4:BD4")

    Set rng = .SpecialCells(xlCellTypeConstants)
    If Err.Number = 0 Then
        Set 最左 = rng.Cells(1)
        Set rng1 = rng.Areas(rng.Areas.Count)
        Set 最右 = rng1.Cells(rng1.Count)
        MsgBox "最右は" & 最右.Column
        MsgBox "最左は" & 最左.Column
    Else

'登録データがない場合

        MsgBox "登録データがありません"
    End If
End With

Worksheets("A").Activate

'一日目既存のデータを消去(新データ貼り付け範囲のみ)
Dim myRng As Range
Dim sp As Variant
Set myRng = Range(Cells(8, 最左), Cells(8, 56))
myRng.Select
Selection.ClearContents
For Each sp In ActiveSheet.Shapes
If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
sp.Delete
End If
Next sp
Set myRng = Nothing

'一日目の登録データをコピー

Sheets("B").Select
Range(Cells(4, 最左), Cells(4, 56)).Copy
Sheets("A").Select
Cells(8, 最左).Select
ActiveSheet.Paste

End Sub

(しんぽん)

 >シートBのデータのコピペができない
 具体的にできないの説明をしてください。

 コピーは出来るが、想定外にコピー
 まったくコピーできない
 エラーになる等

 >Set myRng = Range(Cells(8, 最左), Cells(8, 56))

 このコードでどんなセル範囲がmyRngに設定されることを想定していますか？
 上記の場合、列位置は、正確には
 msgbox 最左.value

 で表示される値になりますが、間違いありませんか？

 間違いないなら、シートＢのRange("I4:BD4")このセル範囲の
 値を見せてください。尚、この範囲が数式なのか値なのかも教えてください

 ichinose

ichinose様

　早速返信いただきありがとうございます。以下に回答を
させていただきます。

　シートBのデータのコピペができない

 具体的にできないの説明をしてください。
 ×　コピーは出来るが、想定外にコピー
 ○　まったくコピーできない
 ×　エラーになる等
Sheets("B").Select 
Range(Cells(4, 最左), Cells(4, 56)).Copy 
Sheets("A").Select 
Cells(8, 最左).Select 
ActiveSheet.Paste 
これ単体のマクロを動かすとBからAにデータがコピペされるのですが、
このマクロの前にAのデータをクリアするマクロがあると結果として
コピペされません。

　Set myRng = Range(Cells(8, 最左), Cells(8, 56))

 このコードでどんなセル範囲がmyRngに設定されることを想定していますか？
 上記の場合、列位置は、正確には
 msgbox 最左.value
 で表示される値になりますが、間違いありませんか？

 間違っておりました。msgbox 再左.valueはRになりました・・・　
 ここを直します。ご指摘、誠にありがとうございました。

　シートＢのRange("I4:BD4")このセル範囲の値を見せてください。
　尚、この範囲が数式なのか値なのかも教えてください

　I4:BD4は、I4にR(文字列),J4からT4までが矢印(⇔)、それとU4がS(文字列),
　V4からBC4が矢印(⇔)でBD4がE(文字列)です。

ichinose様

マクロを書き換え、シートBからシートAへのコピペはできるようになりました。
ご指摘のとおりSet myRng = Range(Cells(8, 最左), Cells(8, 56))が悪かったです。

ichinose様

このleftプロパティが、最小が最左、最大が最右図形となりますが・・・。

その比較のアルゴリズムを　For～Next内に記述することになります。

これは、考えてみてください

この度は、色々ご指導いただき誠にありがとうございました。
上記の件は、とりあえず以下でうまくいきました。

'あるセル範囲にある図形群の最左セル列取得
Dim st() As Variant
Dim i As Integer
Dim 最左 As Integer
Dim sp As shape
Dim myRng As Range
Set myRng = Range("a1:z1")
i = 0
For Each sp In ActiveSheet.Shapes
If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
MsgBox "名前: " & sp.Name & "位置 left : " & sp.Left
i = i + 1
ReDim Preserve st(i)
st(i) = sp.TopLeftCell.Column
End If
Next sp
If i = 0 Then
MsgBox "シェイプ無し"
ElseIf i >= 1 Then
MsgBox "シェイプは" & i & "個あります"
最左 = Application.WorksheetFunction.Min(st(i))
End If

 コード拝見しました。

 Option Explicit
 Sub test()
    'あるセル範囲にある図形群の最左セル列取得
    Dim st() As Variant
    Dim i As Integer
    Dim 最左 As Integer
    Dim sp As Shape
    Dim myRng As Range
    Set myRng = Range("a1:z1")
    i = 0
    For Each sp In ActiveSheet.Shapes
       If Not Intersect(Range(sp.TopLeftCell, sp.BottomRightCell), myRng) Is Nothing Then
          MsgBox "名前: " & sp.Name & "位置 left : " & sp.Left
          i = i + 1
          ReDim Preserve st(i)
          st(i) = sp.TopLeftCell.Column
       End If
    Next sp
    If i = 0 Then
       MsgBox "シェイプ無し"
    ElseIf i >= 1 Then
       MsgBox "シェイプは" & i & "個あります"
       最左 = Application.WorksheetFunction.Min(st())
       '　　ここ、配列の添え字はなしですね
       MsgBox 最左
    End If
 End Sub

 細かいことですが、二つ気になったので････。

 １　インデントは付けるようにしてください
     コードが見やすくなりますから。
     この掲示板では、たまたまで　普段は付けているのなら、余計なお世話ですが。

 ２　Dim st() As Variantについて
     他の変数には、きちんと型宣言をされていたのに
    （但し、Integerは使わず、Longにした方がよいという意見もあります）、どうしてだろう？
     と思っていました・・・・。

   列位置なら、
   Dim st() As long でも良いのにって・・・。

 しかし、提示されたコード

 >最左 = Application.WorksheetFunction.Min(st(i))
 実際には、

 最左 = Application.WorksheetFunction.Min(st())

 これですが、現コードだとこれ、Variant型でなければ、正しい　最左　は、得られません

 宣言を

 Dim st() As long

 としてしまうと最左は、0になってしまいます。

 ReDim Preserve st(i)
 最初にこの配列再構成では、i=1　ですよね？
 この時、stという配列は、St(0) と St(1)が作成されます。

 Variant型の場合、St(0)は、Emptyになります。
 WorksheetFunction.Min(st())は、Emptyは、対象外なので、正しい結果が得られます。

 St()を　Longで宣言すると、　同じようにSt(0)も作成されますが、今度は、
 St(0)=0で、WorksheetFunction.Min(st())で最小値の対象になってしまいます。

 これを知っていてのVarinat型ですか？

 このSt(0)の分だけ一つ多くデータが確保されるだけですから、大したことではありませんが、

 本来は、

 Dim st() As Long

 とLong型に変更し、

 ReDim Preserve st(1 To i)

 Redimを上記のように変更すると、St(0)も生成されず、最左も正しく取得できます。

 検討してみてください

 ichinose

ichinose様

 いつもご指導いただきありがとうございます。ご指摘いただいた2点について

１．インデントについて、全く意識していませんでした。今後気をつけます。
　　コードの見やすさが全然違いますね。

２．変数Integerは全てLongに書き換えました。Redim Preserve st(i)については

    意味がよく分からず使用しておりました。ある範囲内の複数図形の最左,最右
　　列取得の方法として、最初は対象Obj全てをグループ化し、そのプロパティー
　　をとるのが早いかなと思い、検討しておりました。そのときに「全てのオート
　　シェイプを選択しグループ化する」というマクロの例で、このコードを使用
　　していたので、とりあえずObj選択の例として引用しました。しかし、よく
　　考えるとObjを取得してしまえばわざわざグループ化しなくても最左はMIN関数,
　　最右はMAX関数で値が求まることに気づき、上記のようなコードになりました。
　　(初心者ですので常に試行錯誤です・・・)ご指摘いただいた内容については、
　　全く知りませんでした・・・再検討させていただきます。

コメント返信：

[ 一覧(最新更新順) ]

[[20120531104000]] 『あるセル範囲で最左,最右に入力のあるセル番地をメx（しんぽん） ページの最後に飛ぶ

[[20120531104000]]　『あるセル範囲で最左,最右に入力のあるセル番地をメx（しんぽん）　ページの最後に飛ぶ