Excel VBA質問箱 IV

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

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


5152 / 13644 ツリー ←次へ | 前へ→

【52188】らせん状(うず状)に数字を並べていく やまだ 07/10/29(月) 12:59 質問[未読]
【52189】Re:らせん状(うず状)に数字を並べていく ハチ 07/10/29(月) 13:10 発言[未読]
【52190】Re:らせん状(うず状)に数字を並べていく とおりすがり 07/10/29(月) 13:10 発言[未読]
【52191】Re:らせん状(うず状)に数字を並べていく やまだ 07/10/29(月) 13:58 質問[未読]
【52192】Re:らせん状(うず状)に数字を並べていく ichinose 07/10/29(月) 14:24 発言[未読]
【52196】Re:らせん状(うず状)に数字を並べていく 駿 07/10/29(月) 15:04 お礼[未読]
【52193】Re:らせん状(うず状)に数字を並べていく やまだ 07/10/29(月) 14:46 発言[未読]
【52194】Re:らせん状(うず状)に数字を並べていく じゅんじゅん 07/10/29(月) 14:49 発言[未読]
【52197】Re:らせん状(うず状)に数字を並べていく やまだ 07/10/29(月) 15:21 質問[未読]
【52198】Re:らせん状(うず状)に数字を並べていく ichinose 07/10/29(月) 19:39 発言[未読]
【52199】Re:らせん状(うず状)に数字を並べていく やまだ 07/10/29(月) 19:46 お礼[未読]
【52216】Re:らせん状(うず状)に数字を並べていく Jaka 07/10/31(水) 16:03 発言[未読]
【52223】Re:らせん状(うず状)に数字を並べていく 小僧 07/11/1(木) 10:50 回答[未読]
【52224】数学なんて嫌いだ。 Jaka 07/11/1(木) 11:29 発言[未読]
【52329】Re:らせん状(うず状)に数字を並べていく kon 07/11/9(金) 2:11 質問[未読]
【52332】Re:らせん状(うず状)に数字を並べていく ichinose 07/11/9(金) 7:46 発言[未読]
【52349】Re:らせん状(うず状)に数字を並べていく ichinose 07/11/10(土) 8:39 発言[未読]

【52188】らせん状(うず状)に数字を並べていく
質問  やまだ  - 07/10/29(月) 12:59 -

引用なし
パスワード
   初心者ですいません。

数字の1から順番に、中心から外に向かって数字を並べていく
方法を教えてください。

【52189】Re:らせん状(うず状)に数字を並べていく
発言  ハチ  - 07/10/29(月) 13:10 -

引用なし
パスワード
   ▼やまだ さん:
>初心者ですいません。
>
>数字の1から順番に、中心から外に向かって数字を並べていく
>方法を教えてください。

なんだかおもしろそうですが、
意味がわかりません・・・

セルにですか?
それともシェイプで書くのでしょうか?

【52190】Re:らせん状(うず状)に数字を並べていく
発言  とおりすがり  - 07/10/29(月) 13:10 -

引用なし
パスワード
   まず、手作業で螺旋を作る場合のロジック
をお考えください。
それをマクロ化するお手伝いは出来ます。

【52191】Re:らせん状(うず状)に数字を並べていく
質問  やまだ  - 07/10/29(月) 13:58 -

引用なし
パスワード
   ▼やまだ さん:
>初心者ですいません。
>
>数字の1から順番に、中心から外に向かって数字を並べていく
>方法を教えてください。

らせん状といいますか、ただ単に時計回り(または反時計周り)に
数字を並べたいだけなんです。
平面でいいです。セルに数字が入ればいいです。

説明が下手ですいません。
どなたか分かりますでしょうか?

【52192】Re:らせん状(うず状)に数字を並べていく
発言  ichinose  - 07/10/29(月) 14:24 -

引用なし
パスワード
   こんにちは。

一例です。
新規ブックの標準モジュールに
'============================================
Sub Mk_uzu()
  Dim rng As Range
  Dim rs As Double
  Dim x As Double
  Dim y As Double
  Dim z As Double
  Dim cnt As Long
  Dim idx As Double
  Set rng = Range("g20")
  rs = 200
 
  z = 0
  cnt = 1
  x = rng.Left: y = rng.Top
  idx = 0.15
  With rng.Parent
    With .Rectangles.Add(x, y, 15, 15)
     .Text = cnt
     .Font.Size = 7
     End With
    cnt = cnt + 1
   Do Until z > rs
     With .Rectangles.Add(x + z * Cos(idx), y + z * Sin(idx), 15, 15)
      .Text = cnt
      .Font.Size = 7
      End With
     cnt = cnt + 1
     z = z + 1.5
     idx = idx + 0.2
     Loop
   End With
End Sub


上記のMk_uzuを実行してみてください。

後は、間隔を工夫してください。

【52193】Re:らせん状(うず状)に数字を並べていく
発言  やまだ  - 07/10/29(月) 14:46 -

引用なし
パスワード
   ichinoseさん、ありがとうございます。

ですが、私の希望とはちょっと違いまして。。

ただ単に、1〜20の数字をExcelの既存のセルに
並べるという本当に単純なものを教えてほしいです。

何度もすみませんが、どなたかお願いします。

【52194】Re:らせん状(うず状)に数字を並べていく
発言  じゅんじゅん  - 07/10/29(月) 14:49 -

引用なし
パスワード
   >ですが、私の希望とはちょっと違いまして。。
>
>ただ単に、1〜20の数字をExcelの既存のセルに
>並べるという本当に単純なものを教えてほしいです。

どのような形を希望なのか、例題を提示されては?

【52196】Re:らせん状(うず状)に数字を並べていく
お礼  駿  - 07/10/29(月) 15:04 -

引用なし
パスワード
   ▼ichinose さん:
すみません。あまりにも面白かったのでレスさせていただきます。
仕事中なのに声が出てしまい他の人に白い目で見られました。

ichinose さんのを改造して(勉強しながら)アンパンが書けるようなマクロ作ろうと思いました。

これからもお願いします。

【52197】Re:らせん状(うず状)に数字を並べていく
質問  やまだ  - 07/10/29(月) 15:21 -

引用なし
パスワード
   1
2       
3         9 2 3
4  ⇒      8 1 4
5         7 6 5
6        
7        
8
9

簡単に言えば、こんな感じです。

ちなみに、エクセルファイルってここに載せれるんですか?

【52198】Re:らせん状(うず状)に数字を並べていく
発言  ichinose  - 07/10/29(月) 19:39 -

引用なし
パスワード
   ▼やまだ さん:
>1
>2       
>3         9 2 3
>4  ⇒      8 1 4
>5         7 6 5
>6        
>7        
>8
>9
>
>簡単に言えば、こんな感じです。

あっ、そういうことですか?

即興なので、イマイチ気に入らないのですが・・・。
'===========================================================
Sub main()
  Dim g0 As Long
  Dim stt As Long
  Dim rng As Range
  Set rng = Range("g20")
  stt = 1
  For g0 = 1 To 20
    rng.Value = g0
    Set rng = get_rng(rng, stt)
    Next
End Sub
'===========================================================
Function get_rng(ByVal rng, stt As Long) As Range
  Dim mx
  ReDim cnt(1 To 4) As Long
  ReDim chk(1 To 4) As Range
  ReDim locate(1 To 4) As Long
  Dim c As Long
  Dim g0 As Long
  Dim g1 As Long
  Dim g2 As Long
  For g0 = stt To (stt + 3)
  Select Case g0 Mod 4
      Case 1
       Set chk(c + 1) = rng.Offset(-1, 0)
       locate(c + 1) = 1
      Case 2
       Set chk(c + 1) = rng.Offset(0, 1)
       locate(c + 1) = 2
      Case 3
       Set chk(c + 1) = rng.Offset(1, 0)
       locate(c + 1) = 3
      Case 0
       Set chk(c + 1) = rng.Offset(0, -1)
       locate(c + 1) = 4
      End Select
    If chk(c + 1).Value = "" Then
      For g1 = -1 To 1
       For g2 = -1 To 1
         If g1 <> 0 Or g2 <> 0 Then
          If chk(c + 1).Offset(g1, g2).Value <> "" Then
            cnt(c + 1) = cnt(c + 1) + 1
            End If
          End If
         Next
       Next
      End If
    c = c + 1
    Next
  With Application
    g0 = .Match(.Max(cnt()), cnt(), 0)
    End With
  Set get_rng = chk(g0)
  stt = locate(g0)
End Function


>ちなみに、エクセルファイルってここに載せれるんですか?
ここは、出来ないですね!!
でも、だから勉強になるんですよ!!
ここに自分が知りたいことや知っていることを記述するのは大変なことです。

その大変なことをここでやろうとするから、上達するんです。

と、私は思っています。

【52199】Re:らせん状(うず状)に数字を並べていく
お礼  やまだ  - 07/10/29(月) 19:46 -

引用なし
パスワード
   ichinoseさん、本当にありがとうございます。

即興でも完璧だと思います。
これから自分で改良していきたいと思います。

ありがとうございました。

【52216】Re:らせん状(うず状)に数字を並べていく
発言  Jaka  - 07/10/31(水) 16:03 -

引用なし
パスワード
   こんにちは。
なんか面白そうだったので。
正方形セル範囲(縦横同じセル数で、奇数個)にしか対応してません。

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub bbbb()
With Range("D3:L11")
  .ClearContents
  CCt = .Columns.Count
  RCt = .Rows.Count
  真中 = Int(CCt / 2 + 0.5)

  For i = 0 To Int(CCt / 2) Step 1
    RW = i * -1
    'Set Rag2 = .Cells(真中, 真中).Offset(RW, RW).Resize(RW * -2 + 1, RW * -2 + 1)
    
    With .Cells(真中, 真中).Offset(RW, RW).Resize(RW * -2 + 1, RW * -2 + 1)
      '.Select
      If Ct = 0 Then
        Ct = Ct + 1
        .Value = Ct
        Sleep 200 '約0.2秒待機
      Else
        With .Rows(1).Cells.Resize(, .Rows(1).Cells.Count - 1).Offset(, 1)
           '.Select
           For ii = 1 To .Cells.Count Step 1
            Ct = Ct + 1
            .Cells(ii) = Ct
            Sleep 200 '約0.2秒待機
           Next
        End With
        With .Columns(.Columns.Count).Cells.Resize(.Columns(.Columns.Count).Cells.Count - 1).Offset(1)
           '.Select
           For ii = 1 To .Cells.Count Step 1
            Ct = Ct + 1
            .Cells(ii) = Ct
            Sleep 200 '約0.2秒待機
           Next
        End With
        With .Rows(.Rows.Count).Cells.Resize(, .Rows(.Rows.Count).Cells.Count - 1)
           '.Select
           For ii = .Cells.Count To 1 Step -1
            Ct = Ct + 1
            .Cells(ii) = Ct
            Sleep 200 '約0.2秒待機
           Next
        End With
        With .Columns(1).Cells.Resize(.Columns(1).Cells.Count - 1)
           '.Select
           For ii = .Cells.Count To 1 Step -1
             Ct = Ct + 1
             .Cells(ii) = Ct
             Sleep 200 '約0.2秒待機
           Next
        End With
       End If
     End With
  Next
End With
End Sub

【52223】Re:らせん状(うず状)に数字を並べていく
回答  小僧  - 07/11/1(木) 10:50 -

引用なし
パスワード
   ▼やまだ さん、みなさま:
こんにちは。
Jaka さんと一緒でなんか面白そうでしたので…。

Sub 螺旋状に数値を並べる()
Dim i As Long
Dim x As Long
Dim y As Long
Dim R As Range

  Cells.ClearContents
  Cells.RowHeight = 13.5
  Cells.ColumnWidth = 2

'中心のセル
  Set R = Range("S18")
    R.Value = 1
  
  For i = 2 To 20
    Select Case (Int((Sqr(((i - 1) * 4 - 3)) + 1)) - 1) Mod 4
      Case 0
        x = x - 1
      Case 1
        y = y - 1
      Case 2
        x = x + 1
      Case 3
        y = y + 1
    End Select
  
    R.Offset(y, x).Value = i
  Next i

End Sub

【52224】数学なんて嫌いだ。
発言  Jaka  - 07/11/1(木) 11:29 -

引用なし
パスワード
   う〜ん。
皆さん数学してますね。
サインだの平方根。
さっぱりわかりません。

ついでに、
私のコードの場合。

With Range("B3:R19")
  .Select    ← これ入れておくと面白いかも?
  .ClearContents

【52329】Re:らせん状(うず状)に数字を並べていく
質問  kon  - 07/11/9(金) 2:11 -

引用なし
パスワード
   ▼ichinose さん:
>
>あっ、そういうことですか?
>
>即興なので、イマイチ気に入らないのですが・・・。
>'===========================================================
>Sub main()
>  Dim g0 As Long
>  Dim stt As Long
>  Dim rng As Range
>  Set rng = Range("g20")
>  stt = 1
>  For g0 = 1 To 20
>    rng.Value = g0
>    Set rng = get_rng(rng, stt)
>    Next
>End Sub
>'===========================================================
>Function get_rng(ByVal rng, stt As Long) As Range
>  Dim mx
>  ReDim cnt(1 To 4) As Long
>  ReDim chk(1 To 4) As Range
>  ReDim locate(1 To 4) As Long
>  Dim c As Long
>  Dim g0 As Long
>  Dim g1 As Long
>  Dim g2 As Long
>  For g0 = stt To (stt + 3)
>  Select Case g0 Mod 4
>      Case 1
>       Set chk(c + 1) = rng.Offset(-1, 0)
>       locate(c + 1) = 1
>      Case 2
>       Set chk(c + 1) = rng.Offset(0, 1)
>       locate(c + 1) = 2
>      Case 3
>       Set chk(c + 1) = rng.Offset(1, 0)
>       locate(c + 1) = 3
>      Case 0
>       Set chk(c + 1) = rng.Offset(0, -1)
>       locate(c + 1) = 4
>      End Select
>    If chk(c + 1).Value = "" Then
>      For g1 = -1 To 1
>       For g2 = -1 To 1
>         If g1 <> 0 Or g2 <> 0 Then
>          If chk(c + 1).Offset(g1, g2).Value <> "" Then
>            cnt(c + 1) = cnt(c + 1) + 1
>            End If
>          End If
>         Next
>       Next
>      End If
>    c = c + 1
>    Next
>  With Application
>    g0 = .Match(.Max(cnt()), cnt(), 0)
>    End With
>  Set get_rng = chk(g0)
>  stt = locate(g0)
>End Function


このプログラムの説明、解説をどなたか教えていただけないでしょうか?

【52332】Re:らせん状(うず状)に数字を並べていく
発言  ichinose  - 07/11/9(金) 7:46 -

引用なし
パスワード
   ▼kon さん:
おはようございます。

>>即興なので、イマイチ気に入らないのですが・・・。
>>'===========================================================
>>Sub main()
>>  Dim g0 As Long
>>  Dim stt As Long
>>  Dim rng As Range
>>  Set rng = Range("g20")
>>  stt = 1
>>  For g0 = 1 To 20
>>    rng.Value = g0
>>    Set rng = get_rng(rng, stt)
>>    Next
>>End Sub
>>'===========================================================
>>Function get_rng(ByVal rng, stt As Long) As Range
>>  Dim mx
>>  ReDim cnt(1 To 4) As Long
>>  ReDim chk(1 To 4) As Range
>>  ReDim locate(1 To 4) As Long
>>  Dim c As Long
>>  Dim g0 As Long
>>  Dim g1 As Long
>>  Dim g2 As Long
>>  For g0 = stt To (stt + 3)
>>  Select Case g0 Mod 4
>>      Case 1
>>       Set chk(c + 1) = rng.Offset(-1, 0)
>>       locate(c + 1) = 1
>>      Case 2
>>       Set chk(c + 1) = rng.Offset(0, 1)
>>       locate(c + 1) = 2
>>      Case 3
>>       Set chk(c + 1) = rng.Offset(1, 0)
>>       locate(c + 1) = 3
>>      Case 0
>>       Set chk(c + 1) = rng.Offset(0, -1)
>>       locate(c + 1) = 4
>>      End Select
>>    If chk(c + 1).Value = "" Then
>>      For g1 = -1 To 1
>>       For g2 = -1 To 1
>>         If g1 <> 0 Or g2 <> 0 Then
>>          If chk(c + 1).Offset(g1, g2).Value <> "" Then
>>            cnt(c + 1) = cnt(c + 1) + 1
>>            End If
>>          End If
>>         Next
>>       Next
>>      End If
>>    c = c + 1
>>    Next
>>  With Application
>>    g0 = .Match(.Max(cnt()), cnt(), 0)
>>    End With
>>  Set get_rng = chk(g0)
>>  stt = locate(g0)
>>End Function

>このプログラムの説明、解説をどなたか教えていただけないでしょうか?
これの説明をするとなると、時間が必要です。出掛けにちょっと投稿
では無理なので・・・。
(ドキュメントを記述するのは大変です)

夜(もしかしたら明日)までには、何とか投稿しますから、待ってください。


でも、投稿コードは出来がよくないので
Jakaさんや小僧さんのコードを学んだ方がよいと思いますよ!!

【52349】Re:らせん状(うず状)に数字を並べていく
発言  ichinose  - 07/11/10(土) 8:39 -

引用なし
パスワード
   ▼kon さん:
おはようございます。

まず、問題コードですが、アルゴリズムには何の変更もありませんが、一部、変数名として不適切な名前だけ変更しました。
'===========================================================
Sub main()
  Dim g0 As Long
  Dim stt As Long
  Dim rng As Range
  Set rng = Range("g20")
  stt = 1
  For g0 = 1 To 20
    rng.Value = g0
    Set rng = get_rng(rng, stt)
    Next
End Sub
‘========================================
Function get_rng(ByVal rng, s_vec As Long) As Range
‘機能 現在のセルから時計回りで渦巻状に移動しデータを入力するための次にセルを取得する。
‘   尚、渦巻状に連続したセルには、何らかのデータ(空白以外)が設定されているものとする
‘   逆にそれ以外のセルは、未入力であるものとする
‘入力データ  rng 現在のセル
‘      s_vec 渦巻状に進行することを目的に
‘      セルrngと前のセルからの進行方向 
‘      1 上方向 2 右方向 3 下方向 4 左方向

‘出力データ get_rng 現在のセルの位置から時計回りで渦巻状に移動し
‘           データを入力するための次にセル
‘      s_vec  取得したget_rngのrngに対する進行方向
‘      1 上方向 2 右方向 3 下方向 4 左方向
  Dim mx
  ReDim cnt(1 To 4) As Long
  ReDim chk(1 To 4) As Range
  ReDim vecter(1 To 4) As Long
  Dim c As Long
  Dim g0 As Long
  Dim g1 As Long
  Dim g2 As Long
  For g0 = s_vec To (s_vec + 3)
  Select Case g0 Mod 4
      Case 1
       Set chk(c + 1) = rng.Offset(-1, 0)
       vecter(c + 1) = 1
      Case 2
       Set chk(c + 1) = rng.Offset(0, 1)
       vecter(c + 1) = 2
      Case 3
       Set chk(c + 1) = rng.Offset(1, 0)
       vecter(c + 1) = 3
      Case 0
       Set chk(c + 1) = rng.Offset(0, -1)
       vecter(c + 1) = 4
      End Select
    If chk(c + 1).Value = "" Then
      For g1 = -1 To 1
       For g2 = -1 To 1
         If g1 <> 0 Or g2 <> 0 Then
          If chk(c + 1).Offset(g1, g2).Value <> "" Then
            cnt(c + 1) = cnt(c + 1) + 1
            End If
          End If
         Next
       Next
      End If
    c = c + 1
    Next
  With Application
    g0 = .Match(.Max(cnt()), cnt(), 0)
    End With
  Set get_rng = chk(g0)
  s_vec = vecter(g0)
End Function


上記のコードは、時計回りで渦巻状に移動しセルにデータを入力していった結果から
帰納的に見いだした規則性を基に作成したコードです。
私は、学者で無いのでその規則の普遍性については証明していません。

上記コードの前提条件として、
get_rngで取得するセル以前の時計回りに渦巻状を構成するセルには
必ず空白以外のデータが入っている
又、上記以外のセルは、未入力であること。
これが条件です。

上記の条件を踏まえて、渦巻状にデータを入力するためには・・・。

  セルを渦巻状に移動しデータを入力するために現在の位置から移動先は
    1   現在のセルのひとつ行が上のセル 現在のセルがG20なら、G19
    2   現在のセルのひとつ右のセル   現在のセルがG20なら、H20
    3   現在のセルのひとつ行が下のセル 現在のセルがG20なら、G21
    4   現在のセルのひとつ左のセル   現在のセルがG20なら、F20

の4方向になります。
では、渦巻状に移動する次のセルとして上記の4つの方向を何を基準に決定するのか??

上記のFunction get_rngでは、4方向の内、隣接するセルで未入力以外のセルの個数が一番多い
方向を移動セルとして決定しています。
隣接するセルで未入力以外のセルの個数が同じ場合は、現在の方向から時計回りの順で優先します。

例えば、セルG20を出発セルとしている上記のコードでは、

G20(既に値が入力されている)から、4方向共に隣接する未入力以外のセルの個数は1です(共にG20だけが隣接する未入力以外のセルになります)。
よって、現在の進行方向である上のセルであるG19を取得し、G19には、「2」が入力されます。

G19を現在のセル、進行方向は上(1)を入力データして、get_rngは、
  進行方向  上  隣接する未入力以外のセルの個数    1(g19)
        右                     2(g19 とg20)
        下  既に入力済み(G20)なので対象外  0
        左                     2(g19 とg20)
と言う結果になり、時計回りの優先順位から、右方向のセルであるH19(s_vec 2)が取得されます。


このような規則で時計回りの渦巻状にセルに値を入力しています。

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