Excel（エクセル）活用コミュの文字入力の行われている最後のセルまでの行数を得る

お世話になります。
文字が入力されている最後のセルまでの行数を把握し、印刷範囲を設定したいのですが。
力技で、以下のように把握しています。

Sub cell_print_area_set()
'文字入力のある最後のセルを把握し、シートあたりの設定頁数を把握する。
'
Dim ad_str As String
Dim k As Long
Dim i As Integer
'文字の入っているセルを力技で得る
ad_str = Range("a1").SpecialCells(xlCellTypeConstants, xlTextValues).Address
For i = Len(ad_str) To 1 Step -1
If Mid(ad_str, i, 1) = "$" Then
Exit For
End If
Next
k = Right(ad_str, Len(ad_str) - i)

End Sub

書式が広範囲に設定されており、UsedRangeでは把握できません。
しかし、この方法・・・ちょっと頭が悪そうなやりかたなので、ひょっとしたら、恐ろしく簡単な把握方法がありそうな気がしています。

仙人のような各位の、助言を切にお願いいたします。（ＶＶ）ペコリ

コメント(23)

最初
全て
最新の40件

[2] mixiユーザー 03月02日 18:24

＞つぶさん
さっそくありがとうございます。もう試したのですが、それだと値が「１」になっちゃいます。実際はＡＣ６６にテキストが入力されているんですが＾＾；

[3] mixiユーザー 03月02日 18:25

とりあえず、For文以下を
k = Right(ad_str, Len(ad_str) - InStrRev(ad_str, "$"))
にするとか

[4] mixiユーザー 03月02日 18:27

＞マリ男さん
あ。そのほうがスマートではありますね。ただ、実は、かなり古いバージョンのＥＸＣＥＬ（ＥＸＣＥＬ９５＋ＷＳＨ環境）でも動作するようにしたかったもので＾＾；

[5] mixiユーザー 03月02日 18:46

あとは、UsedRangeプロパティで
ActiveSheet.UsedRange.Find(What:="*", After:=Range("A1"), LookIn:=xlTextValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
とかでも最終行を取得できると思います

[7] mixiユーザー 03月02日 19:23

＞マリ男さん
スピード回答。おそれいります（ＶＶ）
インデックスが有効な範囲にありません・・・というエラーがでちゃいますけど＾＾；　汗（シート内に結合されたセルが複雑に入り組んでいるせい？関係ない？）
戻り値はＫに入れちゃっていいんですよね＾＾；
なにか、わたくし勘違いしてますでしょうか＾＾；　汗

[8] mixiユーザー 03月02日 19:23

私は2000を使用していますが
Sub Macro1()
k = ActiveSheet.UsedRange.Find(What:="*", After:=Range("A1"), LookIn:=xlTextValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
MsgBox k
End Sub
で実行可能ですよ

[9] mixiユーザー 03月02日 19:38

＞マリ男さま
ＸＰ＆ＥＸＣＥＬ２００３です。エラーいたしますＴＴ

シートは、さまざまにセル結合がなされており、写真も挿入されています。
さらに罫線枠が１０００行まで設定されています。そこで、先ほどの文字入力の最期のセルを把握し、さらに。。。

'オブジェクトのある最期のセルアドレスを得る
Dim mySh As ShapeRange
Dim adr_bottom As String
ActiveSheet.Shapes.SelectAll '全てを選択
Set mySh = Selection.ShapeRange
With mySh
.Group 'グループ化
.Select 'セレクトしておかないとアングループでエラー
adr_bottom = Selection.BottomRightCell.Address
.Ungroup 'グループ化解除
End With
こんなので、写真の挿入位置の最終セルも確定させ。緻密な計算（爆）で、いくつもあるシートごとの、印刷頁範囲を確定させて、ＰＤＦに一括返還しちゃう・・・というのが今回のＶＢＡの最終目的です。

マリ男様。真摯なご協力ありがとうございます。機種依存があるかもしれない・・・つうことで、今回このコードの簡便化はあきらめて、放置することにいたします（ＶＶ）

[10] mixiユーザー 03月02日 19:45

Sub Macro2()
k = ActiveSheet.UsedRange.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
MsgBox k
End Sub
こんな感じではどうでしょう？

[11] mixiユーザー 03月02日 19:49

＞マリ男様
ぉお～～～～～～～♪かっきぃ～♪
エラーしない！！
これで行きます♪ｍ（＿　＿）ｍ

[12] mixiユーザー 03月02日 19:51

良かったです

[13] mixiユーザー 03月02日 19:52

エラーメッセージは何なんだろう？
新規Bookではマリ男さんのは動かないのでしょうか？
動けば、新規と本チャンBookの違いを探して．．．と進めたらどうだろう。
　

[14] mixiユーザー 03月02日 19:56

>13
多分、私が適当に書いていたので
FindメソッドのLookIn引数を間違えていたのだと思います
ただ、なぜ私の方で動くのかは不明ですが

[16] mixiユーザー 03月02日 20:14

みなさま。ありがとうございます。

「実験検証写真のＥＸＩＦ情報を取り出し表示して、複数のシートにまたがる写真帳を作成し、選択されたシートごとの出力頁数を設定し、一挙に選択フォルダにＰＤＦ出力する」

という野望は完成まで、あと数時間となりました。
しかもコードもカッコよくなりそうです♪
がんばりまつ＾＾

本当に、ありがとうございました。

[17] mixiユーザー 03月02日 20:26

途中に空白行がないのであれば
以下のマクロで最終行がわかりますよ

Dim Wk_Row As Integer

Sub Macro1()
Range("A1").Select
Selection.End(xlDown).Select
Wk_Row = ActiveCell.Row
End Sub

[18] mixiユーザー 03月02日 20:38

Endプロパティ、使っても良かったのですが
空白行があるのか又各列の最終行が一致しているのか不明だったので
使っていませんが、もし空白行がなく、最終行が全て同じ
又はどこかの列が確実に一番下の行であるのであれば
Endプロパティでもいけると思いますね

[19] mixiユーザー 03月02日 21:01

はい。空白は、＞１６のようにワンサカです。

[20] mixiユーザー 03月02日 21:48

以下の方法でできると思います。
　
Sub cell_print_area_set()
　With Cells.SpecialCells(xlCellTypeConstants, xlTextValues)
　　k = .Areas(.Areas.Count).Row + .Areas(.Areas.Count).Rows.Count - 1
　End With
End Sub

[23] mixiユーザー 03月03日 14:28

たいらさん。たにさん。
ぞくぞくと、ありがとうございます。

勉強になるなぁ～～

ただ、あくまで＞１６のように、セル範囲が不特定の列におよんでいる写真はりつけ帳ですから、特定セルの最終行を得る手段は使えないかな～～と＾＾；

最終的には
sub hoge_hoge()
'文字あるいは写真の挿入されている最後のセルを把握し、シートあたりの設定頁数を把握する。
'
　Dim ad_str As String
　Dim k As Long '文字最終セル
　Dim k_p As Long '写真最終セル
　Dim i As Integer
　Dim mySh As ShapeRange
　Dim adr_bottom As String
　k = ActiveSheet.UsedRange.Find(What:="*", After:=Range("A1"), _
　　　LookIn:=xlValues, SearchOrder:=xlByRows, _
　　　SearchDirection:=xlPrevious).Row
'写真等の最終位置を得る
　ActiveSheet.Shapes.SelectAll '全てを選択
　Set mySh = Selection.ShapeRange
　　With mySh
　　　.Group 'グループ化
　　　.Select 'セレクトしておかないとアングループでエラー
　　　　adr_bottom = Selection.BottomRightCell.Address
　　　.Ungroup 'グループ化解除
　　End With
　For i = Len(adr_bottom) To 1 Step -1
　　If Mid(adr_bottom, i, 1) = "$" Then
　　　Exit For
　　　End If
　Next
　k_p = Int(Val(Right(adr_bottom, Len(adr_bottom) - i)))
　'大きいほうを把握
　If k > k_p Then
　　k = k
　　Else
　　k = k_p
　　End If
　ad_str = "$A$1:$AC$" & Trim(Str(Int((((k - 1) \ 40) + 1) * 40)))

　ActiveSheet.PageSetup.PrintArea = ad_str
end sub

このルーチンを
Sub select_page_area()
'複数セレクトされたシートの最大印刷頁範囲を設定する
Dim kw As Worksheet
Dim msg As String
Dim tmp

For Each kw In ActiveWindow.SelectedSheets
Sheets(kw.Name).Select
msg = "４０行設定を行います" & vbCrLf & "選択中の対象シート名[ " & kw.Name & " ]"
tmp = MsgBox(prompt:=msg, Title:="印刷範囲の自動設定", Buttons:=vbInformation + vbYesNoCancel + vbDefaultButton3)
If tmp = vbYes Then
Call acell_print_area_set
ElseIf tmp = vbNo Then
Exit Sub
End If
Next
End Sub

と、このように始末しました＾＾　ありがとう。みなさん。

昼休みに完成しました＾＾ｖ

ログインすると、残り5件のコメントが見れるよ