Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3407 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【62416】選択範囲内で中央の選択範囲の取得 ON 09/7/21(火) 16:27

【62418】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/21(火) 17:01

【62419】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/21(火) 17:10

【62420】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/21(火) 17:23

【62426】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/21(火) 17:50

【62427】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/21(火) 18:32

【62428】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/21(火) 18:48

【62429】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/21(火) 20:32

【62437】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/22(水) 15:16

【62439】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/22(水) 15:51

【62442】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/22(水) 16:39

【62443】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/22(水) 16:44

【62446】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/22(水) 17:00

【62447】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/22(水) 17:12

【62451】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/22(水) 18:12

【62425】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/21(火) 17:45

【62452】Re:選択範囲内で中央の選択範囲の取得 もも 09/7/22(水) 18:35

【62455】Re:選択範囲内で中央の選択範囲の取得 つるりん 09/7/22(水) 19:31

【62456】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/22(水) 19:38

【62470】Re:選択範囲内で中央の選択範囲の取得 ON 09/7/23(木) 14:13


	【62416】選択範囲内で中央の選択範囲の取得

ON - 09/7/21(火) 16:27 -


	引用なし

	パスワード

こんにちは　よろしくお願いいたします

セルの書式設定で、選択範囲内で中央の設定してある場合
その選択範囲を取得することは出来ますか？

できれば、一般操作とマクロ取得の両方の方法が知りたいです

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


	【62418】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/21(火) 17:01 -


	引用なし

	パスワード

選択範囲の中央のセルの値を取得？
位置を取得？
どちらでしょうか。


	【62419】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/21(火) 17:10 -


	引用なし

	パスワード

▼つるりんさん：
ありがとうございます

>選択範囲の中央のセルの値を取得？
>位置を取得？
>どちらでしょうか。

自動記録した場合
　　Range("K7:O7").Select
　　With Selection
　　　　.HorizontalAlignment = xlCenterAcrossSelection
の
Range("K7:O7").Select
です

どこに設定してあるか一覧取得したいと思っています
また
手動時の場合もどこまでのセルが選択対象なのかいまいち不明です
というか、選択範囲を見る方法があるような気がしているのですが
よくわかりません


	【62420】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/21(火) 17:23 -


	引用なし

	パスワード

Option Explicit

Sub try()
Dim myRng As Range
Dim mystr As String
For Each myRng In Selection
　　If myRng.HorizontalAlignment = xlCenter Then
　　　　mystr = myRng.Address
　　　　MsgBox mystr
　　End If
Next
End Sub
こんな感じでしょうか。


	【62425】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/21(火) 17:45 -


	引用なし

	パスワード

複数の場合
Msgboxにアドレスを表示して
該当セルを選択します。
Option Explicit

Sub try()
Dim myRng As Range
Dim mystr As String
For Each myRng In Selection
　　If myRng.HorizontalAlignment = xlCenter Then
　　　　mystr = mystr & myRng.Address & ","
　　End If
Next
mystr = "" & Left(mystr, Len(mystr) - 1) & ""
Range(mystr).Select
MsgBox mystr

End Sub


	【62426】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/21(火) 17:50 -


	引用なし

	パスワード

▼つるりんさん：
ありがとうございます
>こんな感じでしょうか。

では、中央揃え　の取得となってしまいました

Sub try2()
Dim myRng As Range
Dim mystr As String
For Each myRng In Selection
　　If myRng.HorizontalAlignment = 7 Then
　　　　mystr = myRng.Address
　　　　'MsgBox mystr
　　　　Debug.Print mystr
　　　　
　　End If
Next
End Sub

ちょっと修正した　try2　で、
選択範囲の中央　が取得出来ましたが

$K$7
$L$7
$M$7
$N$7
$O$7
$F$8
$G$8
$H$8
$I$8
$J$8
$K$8
$L$8
$M$8
$N$8
$O$8

のとき
セルの設定は
F8:J8
K8:O8
で行われていますが
この情報が取得できません

アドバイスありましたらよろしくお願いいたします


	【62427】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/21(火) 18:32 -


	引用なし

	パスワード

Sub try()
Dim myRng As Range
Dim mystr As String
For Each myRng In Selection
　　If myRng.HorizontalAlignment = 7 Then
　　　　mystr = mystr & myRng.Address & ","
　　End If
Next
Stop
mystr = "" & Left(mystr, Len(mystr) - 1) & ""
Range(mystr).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
MsgBox Selection.Address
End Sub
これでいいのかな＾＾


	【62428】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/21(火) 18:48 -


	引用なし

	パスワード

▼つるりんさん：
ありがとうございます

試してみましたが・・・、
ちょっと違うようですが
アドバイスを参考にもう少し検討してみたいと思います

返信遅くなるような気がしますがよろしくお願いいたします


	【62429】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/21(火) 20:32 -


	引用なし

	パスワード

Sub try()
Dim myRng As Range
Dim mystr As String, celad As String, mystr2 As String
Dim mycell As Range
Dim i As Long

Set myRng = Selection
For i = 0 To myRng.Rows.Count
　　mystr = ""
　　For Each mycell In myRng.Resize(1).Offset(i)
　　　　If mycell.HorizontalAlignment = 7 Then
　　　　　　mystr = mystr & mycell.Address & ","
　　　　End If
　　Next
　　
　　If mystr <> "" Then
　　　　mystr = "" & Left(mystr, Len(mystr) - 1) & ""
　　　　Range(mystr).Select
　　　　mystr2 = ActiveCell.Resize(, Selection.Cells.Count).Address
　　　　celad = celad & mystr2 & vbCrLf
　　End If
Next
　　MsgBox celad
　　Set myRng = Nothing
End Sub
これでいけるかな。


	【62437】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/22(水) 15:16 -


	引用なし

	パスワード

▼つるりんさん：
ありがとうございます

>これでいけるかな。
駄目でした・・・

今更ながらで申し訳ないですが
サンプルDT作成とご提示頂いたコードを実行すると下記のようになってしまいます

取得したい値は
B2:D2
B4:D4
E4:H4
なんですが・・・・

>アドバイスを参考にもう少し検討してみたいと思います
は、前回、頂いたコードで思い浮かんだのが
Resize　でしたが・・・・
新規にご提示頂いたようなきれいなコードはかけないと思いますが
イメージ的には近いものを想像していたと思います

SET_DT　実行後　try6　を実行するとお分かり頂けるかと思います

なんか、無理っぽそうな気がしてきました・・・・

Sub SET_DT()
　
　　Range("B2").Value = ">゜))))彡　　　魚"
　　Range("B2:D2").HorizontalAlignment = xlCenterAcrossSelection

　　Range("B4").Value = "くコ:彡　　　いか"
　　Range("B4:D4").HorizontalAlignment = xlCenterAcrossSelection
　　
　　Range("E4").Value = "~ >゜）～～～　　　　へび"
　　Range("E4:H4").HorizontalAlignment = xlCenterAcrossSelection
　　
End Sub

Sub try6()
Dim myRng As Range
Dim mystr As String, celad As String, mystr2 As String
Dim mycell As Range
Dim i As Long

Range("B1:H5").Select
Set myRng = Selection
For i = 0 To myRng.Rows.Count
　　mystr = ""
　　For Each mycell In myRng.Resize(1).Offset(i)
　　　　If mycell.HorizontalAlignment = 7 Then
　　　　　　mystr = mystr & mycell.Address & ","
　　　　End If
　　Next
　
　　If mystr <> "" Then
　　　　mystr = "" & Left(mystr, Len(mystr) - 1) & ""
　　　　Range(mystr).Select
　　　　mystr2 = ActiveCell.Resize(, Selection.Cells.Count).Address(0, 0)
　　　　celad = celad & mystr2 & vbCrLf
　　End If
Next
　　'MsgBox celad
　　Debug.Print celad
　　
　　Set myRng = Nothing
End Sub

イミディエイトウインドウ
B2:D2
B4:H4


	【62439】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/22(水) 15:51 -


	引用なし

	パスワード

>なんか、無理っぽそうな気がしてきました・・・・
ですが
値があるかで判別すれば出来そうな気がしてきました

少し時間がかかりそうですがもう少し検討してみます
ありがとうございました


	【62442】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/22(水) 16:39 -


	引用なし

	パスワード

おわかりかと思いますが、
書式の情報がセル一つ一つにあるため
該当情報も範囲での取得ができませんでした。
なので選択範囲を行で走査してヒットしたセルの
最初と最後を取得する方法で行いました。
なので、選択行につながって同じ書式を設定
している場合それらを一体とみなします。
もし、設定しているセル数が決まっているなら
その列ごとにループ処理をすれば検出可能ですけどね～。
ほかにいい方法ないかなぁ。


	【62443】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/22(水) 16:44 -


	引用なし

	パスワード

もうひとつ、設定するせる数が決まっているなら（たとえば３セル）
行で走査して3セルごとに検出すればいいと思いますが。


	【62446】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/22(水) 17:00 -


	引用なし

	パスワード

3セルごとに設定してあると仮定して
Option Explicit

Sub try()
Dim myRng As Range
Dim mystr As String, celad As String, mystr2 As String
Dim mycell As Range
Dim i As Long, n As Long, j As Long

Set myRng = Selection
For i = 0 To myRng.Rows.Count
　　mystr = ""
　　For Each mycell In myRng.Resize(1).Offset(i)
　　　　If mycell.HorizontalAlignment = 7 Then
　　　　　　mystr = mystr & mycell.Address & ","
　　　　End If
　　Next

　　If mystr <> "" Then
　　　　mystr = "" & Left(mystr, Len(mystr) - 1) & ""
　　　　Range(mystr).Select
　　　　n = Selection.Count
　　　　For j = 1 To n / 3
　　　　　　mystr2 = ActiveCell.Offset(, (j - 1) * 3).Resize(, j * 3).Address
　　　　　　celad = celad & mystr2 & vbCrLf
　　　　Next
　　End If
Next
　　MsgBox celad
　　Set myRng = Nothing
End Sub


	【62447】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/22(水) 17:12 -


	引用なし

	パスワード

▼つるりんさん：
ありがとうございます

>なので、選択行につながって同じ書式を設定
>している場合それらを一体とみなします。
了解しています

>もうひとつ、設定するせる数が決まっているなら（たとえば３セル）
残念ながら固定ではありません

>値があるかで判別すれば出来そうな気がしてきました
については、検討途中ですが下記のようになっています

ただし、例がよくないみたいなので
SET_DT　を　一部修正して　SET_DT2　を実行しています

上記では
B2,C2,D2,F2,G2,H2,
B4,C4,D4,
E4,F4,G4,H4,
となり取りあえず4行目は把握できたような気がしますが
2行目がうまく処理出来ていません

立て続けに、書き込み頂いたので
途中ですが書き込みさせて頂きました

Sub SET_DT2()

　　Range("B2").Value = ">゜))))彡　　　魚"
　　Range("B2:D2").HorizontalAlignment = xlCenterAcrossSelection
　　
　　Range("F2").Value = ">゜))))彡2　　　魚"
　　Range("F2:H2").HorizontalAlignment = xlCenterAcrossSelection

　　Range("B4").Value = "くコ:彡　　　いか"
　　Range("B4:D4").HorizontalAlignment = xlCenterAcrossSelection
　
　　Range("E4").Value = "~ >゜）～～～　　　　へび"
　　Range("E4:H4").HorizontalAlignment = xlCenterAcrossSelection
　
End Sub

Sub try8()
Dim myRng As Range
Dim mystr As String, celad As String, mystr2 As String
Dim mycell As Range
Dim i As Long

Range("B1:H5").Select
Set myRng = Selection
For i = 0 To myRng.Rows.Count
　　mystr = ""
　　For Each mycell In myRng.Resize(1).Offset(i)
　　　　If mycell.HorizontalAlignment = 7 Then
　　　　
　　　　　　mystr = mystr & mycell.Address(0, 0) & ","
　　　　　　
　　　　　　If IsEmpty(mycell.Offset(0, 1).Value) <> True Then
　　　　　　　　
　　　　　　　　Debug.Print mystr
　　　　　　　　mystr = ""
　　　　　　
　　　　　　End If
　　　　End If
　　Next
　　
　　Debug.Print mystr

　　If mystr <> "" Then
　　　　mystr = "" & Left(mystr, Len(mystr) - 1) & ""
　　　　
　　　　Range(mystr).Select
　　　　Sleep 500
　　　　
　　　　mystr2 = ActiveCell.Resize(, Selection.Cells.Count).Address(0, 0)
　　　　celad = celad & mystr2 & vbCrLf
　　　　
　　　　
　　End If
Next
　
　　Set myRng = Nothing
End Sub


	【62451】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/22(水) 18:12 -


	引用なし

	パスワード

まだ　完成していませんが、下記で何とかなりそうです

ありがとうございました
今後もよろしくお願いいたします

Sub try8()

Dim myRng As Range
Dim mystr As String, celad As String, mystr2 As String
Dim mycell As Range
Dim i As Long

Dim tg_v As String

Range("B1:H5").Select
Set myRng = Selection
For i = 0 To myRng.Rows.Count
　　mystr = ""
　　For Each mycell In myRng.Resize(1).Offset(i)

　　　　If mycell.HorizontalAlignment = 7 Then
　　　　
　　　　　　mystr = mystr & mycell.Address(0, 0) & ","
　　　　　　
　　　　　　If IsEmpty(mycell.Offset(0, 1).Value) <> True Then
　　　　　　　　
　　　　　　　　If mystr <> "" Then
　　　　　　　　　　Debug.Print mystr
　　　　　　　　　　mystr = ""
　　　　　　　　End If

　　　　　　End If
　　　　　　
　　　　Else
　　　　
　　　　　　If mystr <> "" Then
　　　　　　　　Debug.Print mystr
　　　　　　　　mystr = ""
　　　　　　End If
　　　　　　
　　　　End If
　　　　
　　Next
　　
　　If mystr <> "" Then
　　　　Debug.Print mystr
　　End If

Next

　
Set myRng = Nothing
　　
End Sub


	【62452】Re:選択範囲内で中央の選択範囲の取得

もも - 09/7/22(水) 18:35 -


	引用なし

	パスワード

▼ON さん：
こんにちは
横入りすみません。

面白そうでしたので参加させてください。

こんな感じではどうでしょうか？

Sub test()
Dim rngBuf As Range, c As Range
For Each c In Selection
　flgStyle = (c.HorizontalAlignment = xlCenterAcrossSelection)
　flgValue = (c.Value <> "")
　If flgStyle And flgValue Then
　　If rngBuf Is Nothing Then
　　　Set rngBuf = c
　　Else
　　　Debug.Print rngBuf.Address
　　　Set rngBuf = c
　　End If
　ElseIf flgStyle Then
　　Set rngBuf = Application.Union(rngBuf, c)
　ElseIf Not rngBuf Is Nothing Then
　　Debug.Print rngBuf.Address
　　Set rngBuf = Nothing
　End If
Next c
If Not rngBuf Is Nothing Then
　Debug.Print rngBuf.Address
　Set rngBuf = Nothing
End If
End Sub


	【62455】Re:選択範囲内で中央の選択範囲の取得

つるりん - 09/7/22(水) 19:31 -


	引用なし

	パスワード

すごい、完璧ですね！

上記、書式の機能を使ったことなかったんだけど
設定した先頭セルにデータがあるのですね。

設定したセルにデータがなくても
判定できるようにできるのかなぁ
ちょっと考えてみよう。
ももさん、勉強になりました。

ON　さん失礼しました。


	【62456】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/22(水) 19:38 -


	引用なし

	パスワード

▼ももさん：
ありがとうございます

>こんな感じではどうでしょうか？
コードのご提示ありがとうございます
初めてみたような気がします
勉強になります

>　flgStyle = (c.HorizontalAlignment = xlCenterAcrossSelection)
のような記載の仕方はどの辺を勉強すればよいのでしょうか
参考ページ等ご紹介いただけると嬉しいです

また
>なんか、無理っぽそうな気がしてきました・・・・
>値があるかで判別すれば出来そうな気がしてきました
>少し時間がかかりそうですがもう少し検討してみます
は、

実際のところ
つるりんさん　にご提示頂いたコード元に
デバッグしながら、闇雲アプローチで
何とか希望の動作が得られるよう漕ぎ着けたらＯＫみたいな感じで
いつも作りこんでしまうことになっています　(~_~;;;

ご提示頂いたコードでは

For Each c In Selection
　If flgStyle And flgValue Then
　ElseIf flgStyle Then
If Not rngBuf Is Nothing Then

とありますが
自分で記述したコードと構造は同じだと思いますが
闇雲の先で辿りついたものと同じように思えて
本来の姿が理解できていません

イメージ的には
true　folse
and　or
の構造があるような気がしています

わかりにくいと思いますが
この辺の考え方アドバイス頂けると嬉しいです

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


	【62470】Re:選択範囲内で中央の選択範囲の取得

ON - 09/7/23(木) 14:13 -


	引用なし

	パスワード

>デバッグしながら、闇雲アプローチで

>わかりにくいと思いますが
>この辺の考え方アドバイス頂けると嬉しいです

訳のわからない書き込みん申し訳ありませんでした

再現出来ずに申し訳ないのですが
ももさんにご提示頂いたコードで

　ElseIf flgStyle Then
　　Set rngBuf = Application.Union(rngBuf, c)
で
オブジェクト Is Nothing　エラー　みたいなことがありました

動作確認とエラー回避のため、下のような修正を行いました

で、下記Ｑが出てしまいました

Ｑ１
'←コレ2
で、セルの背景色がピンクになる場合はどのようなときでしょうか

Ｑ２
再現できないエラーで申し訳ないのですが
'←コレ1　で　回避したエラー処理は、不適切でしょうか

Ｑ３
'←コレ1　と　'←コレ2
とは、重複しているような気もしますがどうなんでしょう

アドバイスあればよろしくお願いいたします

Option Explicit

Sub test2()

Dim rngBuf As Range, c As Range
Dim flgStyle
Dim flgValue

For Each c In Selection

　flgStyle = (c.HorizontalAlignment = xlCenterAcrossSelection)
　flgValue = (c.Value <> "")
　
　If flgStyle And flgValue Then
　
　　If rngBuf Is Nothing Then
　　　Set rngBuf = c
　　Else
　　　Debug.Print rngBuf.Address
　　　rngBuf.Interior.ColorIndex = 43 '緑
　　　Set rngBuf = c
　　End If
　　
　ElseIf flgStyle Then
　
　　'Set rngBuf = Application.Union(rngBuf, c)
　
　　'On Error Resume Next
　　'Set rngBuf = Application.Union(rngBuf, c)
　　'On Error GoTo 0
　　
　　'If rngBuf IsNot Nothing Then　 'NG
　　'　 Set rngBuf = Application.Union(rngBuf, c)
　　'End If
　　
　　If Not rngBuf Is Nothing Then
　　　 Set rngBuf = Application.Union(rngBuf, c)　 '←コレ1
　　End If
　　
　　
　ElseIf Not rngBuf Is Nothing Then
　　Debug.Print rngBuf.Address
　　rngBuf.Interior.ColorIndex = 6 '黄
　　Set rngBuf = Nothing
　End If
　
Next c

If Not rngBuf Is Nothing Then　 '←コレ2
　Debug.Print rngBuf.Address
　rngBuf.Interior.ColorIndex = 38 'ピンク
　Set rngBuf = Nothing
End If

End Sub

サンプルDT増やしてみました

Sub SET_DT3()

　　Range("B2").Value = ">゜))))彡　　　魚"
　　Range("B2:D2").HorizontalAlignment = xlCenterAcrossSelection
　　
　　Range("F2").Value = ">゜))))彡2　　　魚"
　　Range("F2:H2").HorizontalAlignment = xlCenterAcrossSelection

　　Range("B4").Value = "くコ:彡　　　いか"
　　Range("B4:D4").HorizontalAlignment = xlCenterAcrossSelection
　
　　Range("E4").Value = "~ >゜）～～～　　　　へび"
　　Range("E4:H4").HorizontalAlignment = xlCenterAcrossSelection
　　
　
　　Range("B2:H4").Copy
　　Range("B8").PasteSpecial
　　Range("D14").PasteSpecial
　　Application.CutCopyMode = False
　　
　　Range("B1:J17").Select
　　
　
End Sub


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3407 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free