Excel VBA質問箱 IV

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

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


61406 / 76732 ←次へ | 前へ→

【19946】Re:教えてください
回答  hamar  - 04/11/19(金) 18:39 -

引用なし
パスワード
   こんにちは。
多分あってると思いますが検証してないです。

Sub test()
Dim n As Integer
Dim m As Integer
Dim s As Integer
Dim d As Long
Dim rn As Long
Dim lcheck As Long
Dim quotient As Long
Dim lastrow As Long
Dim check As Long
Dim flag As Boolean

With WorksheetFunction
n = Val(InputBox("n個のアルファベットを"))
m = Val(InputBox("m個のグループに分ける"))

rn = .Power(m, n - m) * .Fact(m)  '考慮する組み合わせ数

Dim myarray() As Variant
ReDim Preserve myarray(1 To rn, 1 To n)
Application.ScreenUpdating = False
Cells.Clear

For i = 1 To n   '組み合わせ作成
  s = 0
  count = 0
  If i < m Then
    For j = 1 To rn
      lcheck = rn \ .Fact(i)
      If count < lcheck Then
        myarray(j, i) = s
      Else
        If s < i - 1 Then
          s = s + 1
        Else
          s = 0
        End If
        count = 0
      End If
      count = count + 1
    Next
  Else
    For j = 1 To rn
      lcheck = .Power(m, n - i)
      If count < lcheck Then
        myarray(j, i) = s
      Else
        If s < m - 1 Then
          s = s + 1
        Else
          s = 0
        End If
        myarray(j, i) = s
        count = 0
      End If
      count = count + 1
    Next
  End If
Next

d = 0    '要素数0のグループがない組み合わせのみ取り出す
For j = 1 To rn
  flag = True
  For k = 1 To m - 1
    count = 0
    For i = 1 To n
      If myarray(j, i) = k Then count = count + 1
    Next
    If count = 0 Then flag = False
  Next
  If flag = True Then
    For i = 1 To n
      Cells(j, i).Offset(-d, 0).Value = myarray(j, i)
    Next
  Else
    d = d + 1
  End If
Next

For i = 1 To rn - d   'ダブリチェック用の数字を割り当てる
  check = 0
  For j = 1 To n
    s = Cells(i, j).Value
    If s <> 0 Then
      check = check + .Power(2, n - j) * _
      .Power(m, .CountIf(Rows(i), s) - 1)
    End If
  Next
  Cells(i, n + 1).Value = check
Next

For i = rn - d To 1 Step -1   'ダブリ削除
  If .CountIf(Columns(n + 1), Cells(i, n + 1).Value) > 1 Then
    Rows(i).Delete xlShiftUp
  End If
Next

lastrow = Range("A65536").End(xlUp).Row   '結果
For i = 1 To lastrow
  For j = 1 To n
    Cells(i, n + 3).Offset(0, Cells(i, j).Value).Value = _
    Cells(i, n + 3).Offset(0, Cells(i, j).Value).Value + Chr(64 + j)
  Next
Next

Application.ScreenUpdating = True
End With
End Sub

0 hits

【19670】教えてください ゆか 04/11/13(土) 16:49 質問
【19673】Re:教えてください Kein 04/11/13(土) 20:22 発言
【19675】Re:教えてください [名前なし] 04/11/13(土) 21:07 発言
【19678】Re:教えてください ichinose 04/11/14(日) 0:15 発言
【19679】Re:教えてください ちゃっぴ 04/11/14(日) 11:34 回答
【19680】Re:教えてください ちゃっぴ 04/11/14(日) 13:56 発言
【19691】ありがとうございます ゆか 04/11/15(月) 12:06 お礼
【19710】教えてください ゆか 04/11/15(月) 16:48 質問
【19946】Re:教えてください hamar 04/11/19(金) 18:39 回答
【19951】Re:教えてください ちゃっぴ 04/11/19(金) 22:15 回答
【19953】Re:教えてください ちゃっぴ 04/11/19(金) 22:21 発言
【19957】Re:教えてください ichinose 04/11/20(土) 0:29 発言
【19958】Re:教えてください ちゃっぴ 04/11/20(土) 0:33 発言
【19959】Re:教えてください 追伸 ichinose 04/11/20(土) 1:22 発言
【20041】ありがとうございました! ゆか 04/11/25(木) 11:42 お礼

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