Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
12076 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【12496】空白でないセルの文字を抽出し詰めて表示したい。 さくら 04/4/6(火) 13:31 質問
【12517】Re:空白でないセルの文字を抽出し詰めて表... Jaka 04/4/6(火) 17:22 回答
【12523】Re:空白でないセルの文字を抽出し詰めて表... さくら 04/4/6(火) 19:50 質問
【12525】Re:空白でないセルの文字を抽出し詰めて表... ichinose 04/4/6(火) 20:57 回答
【12526】それともユーザー定義関数にする？ ichinose 04/4/6(火) 21:49 発言
【12534】Re:それともユーザー定義関数にする？（訂... ichinose 04/4/7(水) 7:37 発言
【12527】Re:空白でないセルの文字を抽出し詰めて表... とまと 04/4/6(火) 21:52 回答
【12545】Re:空白でないセルの文字を抽出し詰めて... さくら 04/4/7(水) 11:31 お礼
【12547】Re:空白でないセルの文字を抽出し詰めて... ichinose 04/4/7(水) 12:00 発言
【12548】Re:空白でないセルの文字を抽出し詰めて... さくら 04/4/7(水) 12:40 お礼
【12496】空白でないセルの文字を抽出し詰めて表示...
質問  さくら  - 04/4/6(火) 13:31 -
引用なし
パスワード
   はじめまして。
できそうでできなくて困っています。
誰か力を貸してください。

回覧図書の希望者リストを作っています。
Sheet1には希望者に自分の所属するグループ（A〜D）の列に名前を記入してもらいます。
(Sheet1)
　　　　A　　　　B　　　　C　　　　D
1　　　　山本　　　　鈴木　　　　　　　　山田
2　　　　　　　　佐藤　　　　　　　　
3　　　　　　　　　　　　　　　　

(Sheet2)
1　　　　2　　　　3　　　　4　　　　5　　　　6　　　　7
山本　　　　鈴木　　　　佐藤　　　　山田　　　　

それをSheet2へA1→A2→A3→B1→B2→B3→C1...→D3の順で空欄セルは無視して詰めて表示させたいのです。今後空欄セルに名前が入っても順番の規則は変えないようにするにはどうすればいいのでしょうか？（例：A2に名前が入ると鈴木さんは３番目になる）
【12517】Re:空白でないセルの文字を抽出し詰めて...
回答  Jaka  - 04/4/6(火) 17:22 -
引用なし
パスワード
   こんにちは。
え〜と、はっきり言いまして全然解りません。
シートレイアウト、データ類等、他で手を抜かないで書いてください。
特にデータ量の少なさ．．．。
なかなか解答がつかないのは、こう言う所が原因かと思います。
ほとんど解っていませんから、適当に作ってみました。

Sub dddrtyjsk()
　　Dim TB() As String
　　TBI = 0
　　For i = 1 To 4
　　　　With Sheets("Sheet1")
　　　　　　If .Cells(1, i).Value <> "" Then
　　　　　　　 TBI = TBI + 1
　　　　　　　 ReDim Preserve TB(1 To TBI)
　　　　　　　 TB(TBI) = .Cells(1, i).Value
　　　　　　End If
　　　　　　Ro = 1
　　　　　　Do Until .Cells(Ro, i).End(xlDown).Row = 65536
　　　　　　　 TBI = TBI + 1
　　　　　　　 ReDim Preserve TB(1 To TBI)
　　　　　　　 Ro = .Cells(Ro, i).End(xlDown).Row
　　　　　　　 TB(TBI) = .Cells(Ro, i).Value
　　　　　　Loop
　　　　End With
　　Next
　　RR = 1: CC = 1
　　For Each ttb In TB
　　　　If CC > 4 Then
　　　　　 RR = RR + 1
　　　　　 CC = 1
　　　　End If
　　　　Sheets("Sheet2").Cells(RR, CC).Value = ttb
　　　　CC = CC + 1
　　Next
　　Erase TB
End Sub
【12523】Re:空白でないセルの文字を抽出し詰めて...
質問  さくら  - 04/4/6(火) 19:50 -
引用なし
パスワード
   すみません。表示がずれて余計に分かりにくくなっているのに回答してくださいましてありがとうございます。
しかし説明が悪かったので実行してみると要望とは違う結果になっていました。
できる限り詳しく説明しますので再度お願いします。

使っているフィールドは(Sheet1)のセルA1〜D3と(Sheet2)のセルA1〜J1です。
(Sheet1)は縦にAグループからDグループに分かれていて、回覧の希望があればグループの列に名前を入れます。　回覧される優先順位はAグループが先で順にBグループ、Cグループ、Dグループと続きます。　また、グループの中でも先に登録した人から優先されるため、A1→A2→A3→B1→B2･･･と名前が入っていればB1よりもA2が優先されます。

(Sheet1)のセルA1〜D3に名前が入っていれば
その順に名前を(Sheet2)のセルA1〜J1へ左詰で表示させたいのです。

(Sheet1)
　 A　 　B　 　C　 　D
1　山田　山下　佐藤　鈴木
2　　　　上田　山本
3　　　　今本

(Sheet2)
　 A 　　B 　　C 　　D 　　E 　　F 　　G 　　H 　　I 　　J
1 山田　山下　上田　今本　佐藤　山本　鈴木

また、途中で希望者が増えた場合にも対応したいのです。
例えばセルA2に”黒川”と追加したとき、(Sheet2)のセルB1に入りそのまま残りは右にずれるように。

(Sheet1)
　 A　 　B　 　C　 　D
1　山田　山下　佐藤　鈴木
2　黒川　上田　山本
3　　　　今本

(Sheet2)
　 A 　　B 　　C 　　D 　　E 　　F 　　G 　　H 　　I 　　J
1 山田　黒川　山下　上田　今本　佐藤　山本　鈴木

この説明で分かっていただけますでしょうか？
すみませんが、再度よろしくお願いします。
【12525】Re:空白でないセルの文字を抽出し詰めて...
回答  ichinose  - 04/4/6(火) 20:57 -
引用なし
パスワード
   ▼さくら さん、Jakaさん、こんばんは。

>すみません。表示がずれて余計に分かりにくくなっているのに回答してくださいましてありがとうございます。
>できる限り詳しく説明しますので再度お願いします。

コード書くのと同じくらい質問内容をわかりやすく書くのも難しかったりするもんです。

調査範囲も狭そうなので以下のようなコードを作りました。

＊＊

シート（Sheet1）の調査範囲（さくらさんの例でいうと、セルA1:D3）を
選択してその状態で以下のマクロを実行してみて下さい。


'=============================================================
Sub test()
　 Dim rng As Range
　 Dim idx As Long
　 Dim jdx As Long
　 Dim temp As Variant
　 Set rng = Selection
　 jdx = 0
　 With Worksheets("sheet2")
　　　.Rows(1).Clear
　　　For idx = 1 To rng.Count
　　　　 With rng
　　　　　 temp = .Cells((idx - 1) Mod .Rows.Count + 1, (idx - 1) \ .Rows.Count + 1).Value
　　　　　 End With
　　　　 If temp <> "" Then
　　　　　　.Cells(1, jdx + 1).Value = temp
　　　　　　jdx = jdx + 1
　　　　　　End If
　　　　 Next
　　　End With
End Sub

>また、途中で希望者が増えた場合にも対応したいのです。
これは、希望者名を入力後、再度、上記コードを同じようにして実行して下さい。

他にもシートのChangeイベントを使用する方法等がありますが、
上のコードのちょっとした変更で可能かと・・・。
【12526】それともユーザー定義関数にする？
発言  ichinose  - 04/4/6(火) 21:49 -
引用なし
パスワード
   別解です。と言ってもロジックはほとんど同じだけど・・・。

まず、以下のコードをユーザー定義関数として使います。
標準モジュールに

'========================================================
Function sort_sp(rng As Range)
　 ReDim wk(1 To 1, 1 To rng.Count)
　 Dim idx As Long
　 Dim jdx As Long
　 Dim temp As Variant
　 jdx = 0
　 For idx = 1 To rng.Count
　　　With rng
　　　　temp = .Cells((idx - 1) Mod .Rows.Count + 1, (idx - 1) \ .Rows.Count + 1).Value
　　　　End With
　　　If temp <> "" Then
　　　　 wk(1, jdx + 1) = temp
　　　　 jdx = jdx + 1
　　　　 End If
　　　Next
　 For idx = jdx + 1 To UBound(wk())
　　　wk(idx) = ""
　　　Next
　 sort_sp = wk()
End Function

***設定方法です。

・配列数式としてワークシートに関数を設定します。

・調査範囲は、(Sheet1)のセルA1〜D3だとします。

・Sheet2のセルA1〜L1を選択して下さい（理由は、4列*3行=調査範囲=12だから）

・選択した状態でセルA1がアクティブになっているはずです。

・そのまま、「=IF(sort_sp(Sheet1!A1:D3)="","",sort_sp(Sheet1!A1:D3))」という
　数式を入力します。

・尚､セルから抜けるときは、通常のEnterキーではなく、配列を使っていますから
　Ctrl+Shift+Enterキーで抜けて下さい。

これで設定終了です。

Sheet1のデータを追加してみて下さい。並び変えられているはずですが・・。
【12527】Re:空白でないセルの文字を抽出し詰めて...
回答  とまと  - 04/4/6(火) 21:52 -
引用なし
パスワード
   みなさんこんばんは。　
参加させてください。

for next と　for each
で書いてみました。

Sub test2()

Dim i As Long
Dim m As Long
Dim c As Range

Dim ws2 As Worksheet
Set ws2 = Worksheets("Sheet2")
ws2.Rows(1).ClearContents
m = 1
With Worksheets("Sheet1")
　　For i = 1 To 4
　　　For Each c In Range(.Cells(1, i), .Cells(65536, i).End(xlUp))
　　　　 If c.Value <> "" Then
　　　　　　ws2.Cells(1, m).Value = c.Value
　　　　　　m = m + 1
　　　　 End If
　　　Next
　　Next i
End With

Set ws2 = Nothing


End Sub
【12534】Re:それともユーザー定義関数にする？（...
発言  ichinose  - 04/4/7(水) 7:37 -
引用なし
パスワード
   おはようございます。
いくつもの間違いあったので、訂正します。


>別解です。と言ってもロジックはほとんど同じだけど・・・。
>
>まず、以下のコードをユーザー定義関数として使います。
>標準モジュールに
>
>'========================================================
Function sort_sp(rng As Range)
　 ReDim wk(1 To 1, 1 To rng.Count)
　 Dim idx As Long
　 Dim jdx As Long
　 Dim temp As Variant
　 Dim b_var As Long
　 jdx = 0
　 b_var = rng.Rows.Count
　 For idx = 0 To rng.Count - 1
　　　temp = rng.Cells(idx Mod b_var + 1, idx \ b_var + 1).Value
　　　If temp <> "" Then
　　　　 wk(1, jdx + 1) = temp
　　　　 jdx = jdx + 1
　　　　 End If
　　　Next
　 For idx = jdx + 1 To UBound(wk(), 2) '←大きい間違い 1！！
　　　wk(1, idx) = "" '大きい間違い　2
　　　Next
　 sort_sp = wk()
End Function

他にも気がついてところを訂正しておきました。


>***設定方法です。
>
>・配列数式としてワークシートに関数を設定します。
>
>・調査範囲は、(Sheet1)のセルA1〜D3だとします。
>
>・Sheet2のセルA1〜L1を選択して下さい（理由は、4列*3行=調査範囲=12だから）
>
>・選択した状態でセルA1がアクティブになっているはずです。
>


・そのまま、「=sort_sp(Sheet1!A1:D3)」という
　数式を入力します。
　空白設定しているのでこれでよかった・・・。


>
>・尚､セルから抜けるときは、通常のEnterキーではなく、配列を使っていますから
>　Ctrl+Shift+Enterキーで抜けて下さい。


>
>これで設定終了です。
>
>Sheet1のデータを追加してみて下さい。並び変えられているはずですが・・。

「ツール」−−「オプション」---「計算方法」で自動に設定して確認して下さい
【12545】Re:空白でないセルの文字を抽出し詰めて...
お礼  さくら  - 04/4/7(水) 11:31 -
引用なし
パスワード
   ichinoseさん、とまとさん、Jakaさん、こんにちは。

色々な解決策をありがとうございます。
どうしてもできなかったものが、１晩のうちに一気に解決し、とても感動しています。

グループが増えてセル範囲が毎回変わるものについてはichinoseさんの"test"を、グループがそのままで固定されているものについてはとまとさんの"test2"を使わせていただこうと思います。　
この度の図書回覧リスト作成業務以外の業務にも色々使えそうで嬉しいです。

また、ichinoseさんのユーザー定義関数については初めて使うものだったのでとても勉強になりました。　ただどうしても最後までうまくいかないのですが、Sheet2のセルA1〜L1に「=sort_sp(Sheet1!A1:D3)」を入れてもSheet2のセルA1〜D1までしか入らず順番が変わってしまいます。また、「=sort_sp(Sheet1!$A$1:$D$3)」にすると全て同じ名前が入ってしまいます。　どこかで私は勘違いして変なことをしているのかもしれません。
もうちょっと勉強してみようと思います。

この度は夜遅くまでつきあっていただき感謝しています。
とても助かりました。
また迷ったときはお願いします(^v^)
【12547】Re:空白でないセルの文字を抽出し詰めて...
発言  ichinose  - 04/4/7(水) 12:00 -
引用なし
パスワード
   ▼さくら さん：
こんにちは。

>また、ichinoseさんのユーザー定義関数については初めて使うものだったのでとても勉強になりました。　ただどうしても最後までうまくいかないのですが、Sheet2のセルA1〜L1に「=sort_sp(Sheet1!A1:D3)」を入れてもSheet2のセルA1〜D1までしか入らず順番が変わってしまいます。また、「=sort_sp(Sheet1!$A$1:$D$3)」にすると全て同じ名前が入ってしまいます。　どこかで私は勘違いして変なことをしているのかもしれません。

たぶん、配列数式の入力方法が違っていると思います。


では、関数を設定するマクロです。sort_spを記述したモジュールに
'=============================================================
Sub 関数設定()
　 With Worksheets("sheet2")
　　　.Range("a1:l1").FormulaArray = "=sort_sp(sheet1!a1:d3)"
　　　End With
End Sub

を記述し､関数設定を実行してみて下さい。
【12548】Re:空白でないセルの文字を抽出し詰めて...
お礼  さくら  - 04/4/7(水) 12:40 -
引用なし
パスワード
   ichinoseさんへ

できました！

しかもこんなに早く返事をもらえるなんて感激です。

この度エクセルの新しい分野を開拓した気分でちょっとわくわくしています。
ichinoseさんに教えていただいたマクロをもとに勉強してみますね。

ありがとうございました(^0^)/
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
12076 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free