[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『文章の接続のパターンを全て表示したい』（近藤）
こんにちは。
https://docs.google.com/spreadsheets/d/1jq7FpCxXoCAa--0kuV8USzW5dY4UOv3G3M3ylxSGZIQ/edit?usp=sharing
このようにセルに文字列を入れているのですが、これをつなげて一つの文章にしていくのですが、これら全ての文章パターンを出したいのです。
例えば
今日一人で梨を買いに行きました！
例えばA2-E2まで単純にセルを＆で接続するだけでなく、下のようにパターンが変わったものも出したいのです。
明日友達と梨を摘みに行きました？
これらを手打ちで相対参照しながら中間データセルを作っていたのですが、今後これらのデータが行でも列でもパターンが増えていくので、相対参照をしながら手打ちでするのはちょっと大変そうだなと思っています。
なにかいい方法はないでしょうか？
＜ 使用 Excel：Excel2013、使用 OS：Windows8 ＞
『複数因子を網羅した全パターンを作成したいのです』 [[20121126205247]]
これ？ （GobGob） 2015/10/03(土) 17:36
まぁ、その関係でしょうね。 （ゆうき） さんとか (まさみ)さんとか、（近藤）さんとか、同じ人ではなく、お仲間のようですが、 それなら、自分の仲間のこのトピを受けて、今度は自分が・・といったコメントがあったほうが わかりやすいんですけどねぇ。
不格好な間に合わせのコードです。 ちゃんとしたものは、これから考えてみますし、他の方々からの回答もあるかと思います・・・・ 行は増えても大丈夫ですけど、列が増えたら、f,g,h,・・・・とネストを付け加えたコードに修正していく必要があります。
結果は "シート2" に書きこみます。
Sub とりあえず急ぎで()
Dim w As Variant
Dim a As Range
Dim b As Range
Dim c As Range
Dim d As Range
Dim e As Range
With Sheets("シート1").Range("A1").CurrentRegion.Offset(1)
For Each a In .Columns("A").SpecialCells(xlCellTypeConstants)
For Each b In .Columns("B").SpecialCells(xlCellTypeConstants)
For Each c In .Columns("C").SpecialCells(xlCellTypeConstants)
For Each d In .Columns("D").SpecialCells(xlCellTypeConstants)
For Each e In .Columns("E").SpecialCells(xlCellTypeConstants)
If IsArray(w) Then
ReDim Preserve w(1 To UBound(w) + 1)
Else
ReDim w(1 To 1)
End If
w(UBound(w)) = a & b & c & d & e
Next
Next
Next
Next
Next
End With
With Sheets("シート2")
.UsedRange.ClearContents
.Range("A1").Resize(UBound(w)).Value = WorksheetFunction.Transpose(w)
.Select
End With
End Sub
（β） 2015/10/03(土) 17:56
解決したようなので・・・。 以前、今回の質問のような変則組合せリストというか変則総当たりリストを取得する プログラム群を作成したことがありました。
機能として先に作成しておいたものの たまに行うテストという事で・・・。
新規ブックにて
標準モジュール（Module1）に変則総当たりリスト作成ルーチン
Option Explicit
Private ttl_rng() As Range
Private ttl_idx() As Long
Private ttl_a_num As Long
'===================================================================
Sub ttlhit_init(hitnum As Long)
'変則総当たり処理の開始宣言
'input : hitnum 抜き取り数
Dim g0 As Long
Erase ttl_rng()
Erase ttl_idx()
ReDim ttl_rng(1 To hitnum)
ReDim ttl_idx(1 To hitnum)
For g0 = LBound(ttl_idx()) To UBound(ttl_idx())
ttl_idx(g0) = 1
Next
ttl_idx(UBound(ttl_idx())) = 0
ttl_a_num = 0
End Sub
'======================================================================
Sub ttlhit_add(rng As Range)
'総当たり標本セル範囲の登録
'input : rng 連続したセル範囲
Set ttl_rng(ttl_a_num + 1) = rng
ttl_a_num = ttl_a_num + 1
End Sub
'======================================================================
Function ttlhit_get(ans()) As Long
''変則総当たりメンバーを配列に出力する
'output: ans() メンバの配列
' ttlhit_get:0 -- 正常に配列取得
' 1 -- メンバの終わり
Dim g0 As Long
ttlhit_get = 1
For g0 = UBound(ttl_idx()) To LBound(ttl_idx()) Step -1
If ttl_idx(g0) + 1 <= ttl_rng(g0).Count Then
ttl_idx(g0) = ttl_idx(g0) + 1
ttlhit_get = 0
Exit For
Else
ttl_idx(g0) = 1
End If
Next
If ttlhit_get = 0 Then
For g0 = LBound(ttl_idx()) To UBound(ttl_idx())
ans(g0) = ttl_rng(g0).Cells(ttl_idx(g0)).Value
Next
End If
End Function
'======================================================================
Sub ttlhit_term()
''変則総当たり処理終了
Erase ttl_rng()
Erase ttl_idx()
ttl_a_num = 0
End Sub
標準モジュール（Module2）に文章の接続のパターンを全て表示するメイン関連プログラム
Option Explicit
Sub main()
Dim idx As Long
Dim g0 As Long
Dim nktr As Variant
Dim ans() As Variant
' ↑組み合わせメンバーを取得する配列
Dim rng As Range
' ↑組み合わせセル範囲
Call サンプル作成
MsgBox "サンプル作成 次のシートのセルＡ２から処理を開始します"
Set rng = Range("a1").CurrentRegion.Offset(1, 0)
nktr = Application.InputBox("1〜6の組合せ列をカンマで区切って指定してください", , "", , , , , 2)
If TypeName(nktr) <> "Boolean" Then
If nktr = "" Then nktr = "1,2,3,4,5,6"
nktr = Split(nktr, ",")
Call ttlhit_init(UBound(nktr) + 1)
For g0 = LBound(nktr) To UBound(nktr)
With rng
Call ttlhit_add(Range(.Cells(1, Val(nktr(g0))), .Cells(1, Val(nktr(g0))).End(xlDown)))
End With
Next
idx = 1
ReDim ans(1 To UBound(nktr) + 1)
With ActiveSheet.Next
.Cells.ClearContents
For g0 = LBound(nktr) To UBound(nktr)
.Cells(1, g0 + 1).Value = rng.Cells(0, Val(nktr(g0))).Value
Next
Do While ttlhit_get(ans()) = 0
idx = idx + 1
.Cells(idx, 1).Resize(, UBound(nktr) + 1).Value = ans()
Loop
.Columns("a:f").AutoFit
End With
MsgBox "以上" & (idx - 1) & "通り"
Call ttlhit_term
End If
End Sub
'============================================================
Sub サンプル作成(Optional sht As Worksheet)
If sht Is Nothing Then Set sht = ActiveSheet
With sht
.Cells.ClearContents
.Range("a1:f1").Value = [{"いつ","誰と","どこに","何を","する","最後"}]
.Range("a2:f2").Value = [{"今日","一人で","長野県に","梨を","買いに行きました","!"}]
.Range("a3:f3").Value = [{"明日","友達と","新潟県に","柿を","探しにいきました","。"}]
.Range("a4:f4").Value = [{"来週","まーちゃんと","福岡県に","","摘みに行きました","！！！"}]
.Range("a5:f5").Value = [{"今週","お母さんと","","","欲しいと思ったけど結局行けなかった","？"}]
.Range("a6:f6").Value = [{"今年","","","","ほしいな〜という話をしたので楽しかった","！！！！"}]
.Range("a7:f7").Value = [{"来年","","","","","？！！"}]
.Columns("a:f").AutoFit
End With
End Sub
使用方法
アクティブシートに例にあげられたようなデータ（ひとつ列増やしました）を作成し、
アクティブシートの右隣のシートにリストを作成します。
mainを実行すると、アクティブシートに基データが作成され、次いで組合せ対象列の入力を促されます。 何も入力しないでOKボタンをクリックすると、1〜6列すべてが組合せ対象になります。
特定列を組合せ対象にするには、 カンマで区切って 対象列を指定し、OKボタンをクリックします。
例
2 1,6 1,3,5 2,3,6 1,2,5,6
細かいエラー処理はしていませんが、これで指定列の組合せリストが基データのあるシートの右隣のシートに作成されます。
（ ichinose） 2015/10/04(日) 07:05
とりあえず、列の増加にも対応したものを書きましたのでアップしておきます。
Sub Sample()
Dim w1 As Variant
Dim w2 As Variant
Dim w3 As Variant
Dim v As Variant
Dim tmp As Variant
Dim ans As Variant
Dim col As Range
Dim i As Long
Dim j As Long
Dim z As Long
Dim x As Long
Dim c As Range
With Sheets("シート1").Range("A1").CurrentRegion
With .Offset(1).Resize(.Rows.Count - 1)
ReDim w1(1 To .Columns.Count)
ReDim w2(1 To .Columns.Count)
ReDim w3(1 To .Columns.Count)
ReDim tmp(1 To .Columns.Count)
z = 1
For j = .Columns.Count To 1 Step -1
Set w1(j) = .Columns(j).SpecialCells(xlCellTypeConstants)
w2(j) = w1(j).Cells.Count
If j = .Columns.Count Then
w3(j) = 1
Else
w3(j) = w2(j + 1) * w3(j + 1)
End If
z = z * w2(j)
Next
ReDim v(1 To z, 1 To .Columns.Count)
ReDim ans(1 To z, 1 To 1)
For j = 1 To .Columns.Count
i = 1
For y = 1 To z \ (w2(j) * w3(j))
For Each c In w1(j)
For x = 1 To w3(j)
v(i, j) = c.Value
i = i + 1
Next
Next
Next
Next
For i = 1 To z
For j = 1 To .Columns.Count
tmp(j) = v(i, j)
Next
ans(i, 1) = Join(tmp, "")
Next
End With
End With
With Sheets("シート2")
.UsedRange.ClearContents
.Range("A1").Resize(UBound(ans)).Value = ans
.Select
End With
End Sub
（β） 2015/10/04(日) 17:19
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.