Excel VBA質問箱 IV

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

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


8066 / 13645 ツリー ←次へ | 前へ→

【35281】貼り付けた画像ファイルを特定セルのみに移動させるには? たく 06/2/25(土) 12:28 質問[未読]
【35288】ここまでやってみました たく 06/2/25(土) 21:17 発言[未読]
【35297】Re:ここまでやってみました やっちん 06/2/25(土) 23:12 発言[未読]
【35305】Re:ここまでやってみました たく 06/2/26(日) 1:42 お礼[未読]
【35307】Re:ここまでやってみました やっちん 06/2/26(日) 2:36 発言[未読]
【35311】Re:ここまでやってみました たく 06/2/26(日) 10:41 お礼[未読]
【35315】困りました たく 06/2/26(日) 14:34 質問[未読]
【35316】Re:困りました やっちん 06/2/26(日) 15:14 発言[未読]
【35318】Re:困りました やっちん 06/2/26(日) 15:44 発言[未読]
【35320】ありがとうございます たく 06/2/26(日) 16:42 お礼[未読]

【35281】貼り付けた画像ファイルを特定セルのみに...
質問  たく  - 06/2/25(土) 12:28 -

引用なし
パスワード
   ジグソーパズル(みたいなもの)を作ってみようと思いあれこれ試しています。
例えば貼り付けた1つの画像をドラッグしたとき、左上端がC5セルにあったら画像をC5に貼り付け、それ以外のところにあったら元の位置に戻してしまう。
何かいい手があったら教えてください。

【35288】ここまでやってみました
発言  たく  - 06/2/25(土) 21:17 -

引用なし
パスワード
   動かしたい画像を"thing1"
C5のセルにオートシェイプで作った透明の四角を置き"thing2"
別のセルにオートシェイプで作った透明の四角を置き"thing3"として、
"thing1"と"thing2"が重なったら"thing1"を"thing2"の場所に移動、
重ならなかったら"thing3"の場所に戻すようにしました。

2回目以降エラーが出ます。
どこを直したらいいでしょうか。
わかる方、教えてください。


Sub check()

Dim X(1 To 3) As Integer 'X座標
Dim Y(1 To 3) As Integer 'Y座標
Dim W(1 To 3) As Integer '幅
Dim H(1 To 3) As Integer '高さ

Dim i As Integer
Dim kasanari As Boolean

For i = 1 To 3
  
  X(i) = ActiveSheet.Shapes("thing" & i).Left
  Y(i) = ActiveSheet.Shapes("thing" & i).Top
  W(i) = ActiveSheet.Shapes("thing" & i).Width
  H(i) = ActiveSheet.Shapes("thing" & i).Height
  
Next i

If Y(1) < Y(2) + H(2) Then
 If Y(1) + H(1) > Y(2) Then
  If X(1) < X(2) + W(2) Then
   If X(1) + W(1) > X(2) Then
    kasanari = True
   End If
  End If
 End If
End If

If kasanari Then
  With ActiveSheet.Shapes("thing1")
  .Top = Y(2)
  .Left = X(2)
  End With
Else
  With ActiveSheet.Shapes("thing1")
  .Top = Y(3)
  .Left = X(3)
  End With
End If

End Sub

【35297】Re:ここまでやってみました
発言  やっちん  - 06/2/25(土) 23:12 -

引用なし
パスワード
   ▼たく さん:
こんばんは。
ちゃんと動きましたよ。
エラーは出ませんでした。
これって何のタイミングで動くコードなんですか?

【35305】Re:ここまでやってみました
お礼  たく  - 06/2/26(日) 1:42 -

引用なし
パスワード
   ▼やっちん さん:ありがとうございます。そうですね。
VBAはドラッグしたときにイベントは発生しませんよね。
判定ボタンを作っていちいち押すのは面倒です。
何も考えずに作ってしまいました。
アドバイスあったら、お願いします。

少し変えました。


Sub check()

'3つのオブジェクトの位置と大きさを求める

Dim X(1 To 3) As Integer 'X座標
Dim Y(1 To 3) As Integer 'Y座標
Dim W(1 To 3) As Integer '幅
Dim H(1 To 3) As Integer '高さ

Dim i As Integer
Dim kasanari As Boolean

For i = 1 To 3
  
  X(i) = ActiveSheet.Shapes("thing" & i).Left
  Y(i) = ActiveSheet.Shapes("thing" & i).Top
  W(i) = ActiveSheet.Shapes("thing" & i).Width
  H(i) = ActiveSheet.Shapes("thing" & i).Height
  
Next i

'重なり方の判定

If Y(1) < Y(2) + H(2) Then
 If Y(1) + H(1) > Y(2) Then        ← + H(1)はいらない?
  If X(1) < X(2) + W(2) Then
   If X(1) + W(1) > X(2) Then      ← + W(1)はいらない?
    kasanari = True
   End If
  End If
 End If
End If

'重なっているとき

If kasanari Then
  With ActiveSheet.Shapes("thing1")
  .Top = Y(2)              ← .Top = Y(2) + 1 に変更
  .Left = X(2)              ← .Left = X(2) + 1 に変更

  End With

'重なっていないとき

Else
  With ActiveSheet.Shapes("thing1")
  .Top = Y(3)
  .Left = X(3)
  End With
End If

End Sub

【35307】Re:ここまでやってみました
発言  やっちん  - 06/2/26(日) 2:36 -

引用なし
パスワード
   ▼たく さん:
>  If Y(1) < Y(2) + H(2) Then
>   If Y(1) + H(1) > Y(2) Then        ← + H(1)はいらない?
>    If X(1) < X(2) + W(2) Then
>     If X(1) + W(1) > X(2) Then      ← + W(1)はいらない?
>      kasanari = True
>     End If
>    End If
>   End If
>  End If
H(1),W(1)はいるでしょう。=があってもいいと思います。

実行タイミングは、一定間隔でするような方法になるんでしょうか。
そのぐらいしか私には思いつきません。

【35311】Re:ここまでやってみました
お礼  たく  - 06/2/26(日) 10:41 -

引用なし
パスワード
   ▼やっちん さん:ありがとうございます。
そうですね。一定間隔という手がありました。
まだイメージが希薄ですが、いろいろ試してみることにします。

【35315】困りました
質問  たく  - 06/2/26(日) 14:34 -

引用なし
パスワード
   動かすパーツを3つにして
thing1,thing4,thing7を
thing2,thing5,thing8と重なっていたらそのところに
重ならなかったらthing3,thing6,thing9のところに動かそうとしています。

Dim kasanari(j) As Boolean

これ以降の書き方、どうすればいいでしょうか?


Sub check()

'9つのオブジェクトの位置と大きさを求める

Dim X(1 To 9) As Integer 'X座標
Dim Y(1 To 9) As Integer 'Y座標
Dim W(1 To 9) As Integer '幅
Dim H(1 To 9) As Integer '高さ

Dim i As Integer     

For i = 1 To 9

  X(i) = ActiveSheet.Shapes("thing" & i).Left 
  Y(i) = ActiveSheet.Shapes("thing" & i).Top  
  W(i) = ActiveSheet.Shapes("thing" & i).Width 
  H(i) = ActiveSheet.Shapes("thing" & i).Height
  
Next i

'重なり方の判定

Dim j As Integer

For j = 1 To 3

Dim kasanari(j) As Boolean 

                 
If Y(j * 3 - 2) < Y(j * 3 - 1) + H(j * 3 - 1) Then  
 If Y(j * 3 - 2) + H(j * 3 - 2) > Y(j * 3 - 1) Then         
  If X(j * 3 - 2) < X(j * 3 - 1) + W(j * 3 - 1) Then
   If X(j * 3 - 2) + W(j * 3 - 2) > X(j * 3 - 1) Then       
    kasanari(j) = True
   End If
  End If
 End If
End If

'重なっているとき

If kasanari(j) Then
  With ActiveSheet.Shapes("thing" & j * 3 - 2)
  .Top = Y(j * 3 - 1) + 1   
  .Left = X(j * 3 - 1) + 1   
  End With

'重なっていないとき

Else               
  With ActiveSheet.Shapes("thing" & j * 3 - 2)
  .Top = Y(j * 3)       
  .Left = X(j * 3)
  End With
End If

Next j

End Sub

【35316】Re:困りました
発言  やっちん  - 06/2/26(日) 15:14 -

引用なし
パスワード
   ▼たく さん:
こんにちは。
>Dim kasanari(j) As Boolean
は途中に入れずに
最初に
Dim kasanari(3) As Boolean
でいいんじゃないでしょうか。

【35318】Re:困りました
発言  やっちん  - 06/2/26(日) 15:44 -

引用なし
パスワード
   1秒間隔で動くようにしてみました。
Timer_Startをスタートのボタンに登録して、
Timer_ENdをエンドのボタンに登録して動かしてみてください。

Option Explicit
Dim X(1 To 9) As Integer 'X座標
Dim Y(1 To 9) As Integer 'Y座標
Dim W(1 To 9) As Integer '幅
Dim H(1 To 9) As Integer '高さ
Dim MyTime As Date

Sub Timer_Start()
Dim i As Integer

For i = 1 To 9
  X(i) = ActiveSheet.Shapes("thing" & i).Left
  Y(i) = ActiveSheet.Shapes("thing" & i).Top
  W(i) = ActiveSheet.Shapes("thing" & i).Width
  H(i) = ActiveSheet.Shapes("thing" & i).Height

Next i
MyTime = Now() + TimeValue("00:00:01")
Application.OnTime MyTime, "check"
End Sub

Sub Timer_ENd()
On Error Resume Next
Application.OnTime MyTime, "check", , False

End Sub

Sub check()
Dim kasanari As Boolean
Dim j As Integer
Dim i As Integer
Dim Xx(1 To 3) As Integer 'X座標
Dim Yy(1 To 3) As Integer 'Y座標

For i = 1 To 3
  Xx(i) = ActiveSheet.Shapes("thing" & ((i - 1) * 3 + 1)).Left
  Yy(i) = ActiveSheet.Shapes("thing" & ((i - 1) * 3 + 1)).Top
Next i

'重なり方の判定


For j = 1 To 3
  kasanari = False
  If Xx(j) <> X((j - 1) * 3 + 1) Or Yy(j) <> Y((j - 1) * 3 + 1) Then
    X((j - 1) * 3 + 1) = Xx(j)
    Y((j - 1) * 3 + 1) = Yy(j)
    If Y(j * 3 - 2) < Y(j * 3 - 1) + H(j * 3 - 1) Then
     If Y(j * 3 - 2) + H(j * 3 - 2) > Y(j * 3 - 1) Then
      If X(j * 3 - 2) < X(j * 3 - 1) + W(j * 3 - 1) Then
       If X(j * 3 - 2) + W(j * 3 - 2) > X(j * 3 - 1) Then
        kasanari = True
       End If
      End If
     End If
    End If
    
    '重なっているとき
    
    If kasanari Then
      With ActiveSheet.Shapes("thing" & j * 3 - 2)
      .Top = Y(j * 3 - 1) + 1
      .Left = X(j * 3 - 1) + 1
      End With
    
    '重なっていないとき
    
    Else
      With ActiveSheet.Shapes("thing" & j * 3 - 2)
      .Top = Y(j * 3)
      .Left = X(j * 3)
      End With
    End If
  End If
Next j

MyTime = Now() + TimeValue("00:00:01")
Application.OnTime MyTime, "check"

End Sub

【35320】ありがとうございます
お礼  たく  - 06/2/26(日) 16:42 -

引用なし
パスワード
   ▼やっちん さん:言い表せないほどの感謝の気持ちでいっぱいです。
やりたかったことが完成してしまいました。

1行ずつコードを解析して、今後の発展の材料にさせていただきます。
今後もよろしくご指導のほど、お願いいたします。

8066 / 13645 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free