Excel VBA質問箱 IV

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

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


12075 / 13645 ツリー ←次へ | 前へ→

【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に名前が入ると鈴木さんは3番目になる)

【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さん、こんにちは。

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

グループが増えてセル範囲が毎回変わるものについては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^)/

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