[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『文章の接続のパターンを全て表示したい』(近藤)
こんにちは。
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 "サンプル作成 次のシートのセルA2から処理を開始します" 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.