[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別シートを参照して一覧を作成する』(HARU)
初めまして。よろしくお願いいたします。
以下の様な表があります。
<シート1>・・・・・・・・・・・・・・
A列 B列
1 田中、山田、川崎 神奈川
2 Aチーム
3 内村、村上、槌田 大阪
4 Bチーム
5 土屋、鈴木、一場 青森
6 Cチーム
7 溝口、中村、小川 青森
8 Cチーム
<シート2>・・・・・・・・・・・・・・
A列 B列
1 田中 A
2 山田 A
3 川崎 A
4 内村 B
5 村上 B
6 槌田 B
7 土屋 C
8 鈴木 C
9 一場 C
10 溝口 C
11 中村 C
12 小川 C
シート1を参照し、シート2の様にするには、どの関数を使用すれば良いでしょうか?
※シート1のA1のセルには、田中、山田、川崎と名前がカンマ区切りで羅列されています。
※シート1のB1とB2にチーム名が記載されています。これを一纏めにして「神奈川Aチーム」とし、シート2で神奈川AチームをB列のA1〜3に「A」と表示。
このような説明で理解していただけるか不安ですが、ご教授いただけますと幸いです。
< 使用 Excel:Excel2007、使用 OS:Windows7 >
シート1のA列で1セルに3名有るのは、表の作成上必ずこの形になりますか? 私自身このような作り方は好きではないのですが、 「区切り位置」でほかのセルに分割とかではダメでしょうか?
関数で分けるなら、例えばシート1のD1に =TRIM(MID(SUBSTITUTE($A1,"、",REPT(" ",100)),COLUMN(A1)*100-99,100)) として、右と下にコピー
D1を利用してシート2に OFFSET関数で表示させる
私がお手伝いできるのはここまでですね。
(jun53) 2014/07/08(火) 23:35
関数で出来るか参戦!
Sheet2!A1 =TRIM(MID(SUBSTITUTE(INDEX(Sheet1!$A:$A,CEILING(ROW()/3,1)+CEILING(ROW()/3,1)-1),"、",REPT(" ",100)),CHOOSE(MOD(ROW(),3)+1,200,1,100),99))
Sheet2!A1 =SUBSTITUTE(INDEX(Sheet1!$B:$B,CEILING(ROW()/3,1)+CEILING(ROW()/3,1)),"チーム","")
私にはこれくらいしか思いつかなかった・・・ 必ず3人の前提です。(2人の場合3人目が空白、4人の場合、3人までしか表示できない)
(稲葉) 2014/07/09(水) 10:04
>シート1のA列で1セルに3名有るのは、表の作成上必ずこの形になりますか?
ややこしいのが、毎回3人とは決まっておらず、10人だったり5人だったりとその都度人数が違うので困っております・・・。
お二人のご回答を参考に自分でも色々試してみます。ありがとうございました。
もし、他の方で近いものが出せるようなヒントをいただけるようであれば、引き続きお待ちしておりますので、よろしくお願いいたします。
※関数でなくても構いません。
(HARU) 2014/07/09(水) 13:29
じゃ、作業列+手作業入りで。参考程度に。
シート1のD列からF列までを作業列とする。
D1に0を入力 D2に=SUM(D1,IF(A1="",0,LEN(A1)-LEN(SUBSTITUTE(A1,"、",""))+1)) 最後の行(提示例だと8行目のCチームの行まで)まで下にフィルコピー。
E1に=COUNT(D:D) E2に=MAX(D:D)
F1に=SUBSTITUTE(A1&" "&F2,"、"," ") また最終行までフィルコピー。
上記が終わったらF1をコピー。 シート2のB1に「値」貼り付け。 そのままデータタブから「区切り位置」 「カンマやタブなどの区切り文字〜〜」にチェックを入れて「次へ」 スペースにチェックを入れ「連続した区切り文字は一文字〜〜」にチェックを入れ「完了」
横に伸びた名前を選択し、コピー。 シート2のA1選択して「行列を入れ替える」で貼り付け。 B1から横に伸びた名前は削除。
シート2のB1に =IF(Sheet1!E$2<ROW(A1),"",LOOKUP(ROW(A1)-1,Sheet1!D$1:INDEX(Sheet1!D:D,Sheet1!E$1),Sheet1!B$2:INDEX(Sheet1!B:B,Sheet1!E$1+1))) 名前の分だけ下にフィルコピー。
(1111) 2014/07/09(水) 15:39
VBAならこんな感じ? Option Explicit Sub HARU() Dim tbl Dim i As Long, j As Long Sheets("Sheet2").Cells.ClearContents With Sheets("Sheet1") For i = 1 To .Range("A" & .Rows.Count).End(xlUp).Row Step 2 tbl = Application.Transpose(Split(.Cells(i, "A").Value, "、")) ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2) For j = 1 To UBound(tbl, 1) tbl(j, 2) = Left(.Cells(i + 1, "B"), 1) Next j Sheets("Sheet2").Range("A" & Cells.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl Next i End With Sheets("Sheet2").Range("A1").EntireRow.Delete End Sub (稲葉) 2014/07/09(水) 17:47
1111さんのやり方参考になりました。
ただ、今回のデータ量が多すぎて手作業を挟むと時間がかかりすぎてしまう為、できるだけ手間を省けるやり方を探しておりました。
でも、大変参考になり、今後の応用として教えていただいた方法を使わせていただきたいと思います!
稲葉さん、再度ご回答いただきまして感謝いたします!
記載していただいたVBAを試した所、思っていた形式に仕上がりました♪
が・・・Sheet1のA1以降がSheet2に反映されませんでした・・・。
VBAはまだまだ勉強不足でどこを修正するのかさえ分かっていませんが、後は、自力で頑張るしかないですね(笑)
毎回、皆さんの回答が早くて本当に助かります!ありがとうございました♪
(HARU) 2014/07/10(木) 10:48
>が・・・Sheet1のA1以降がSheet2に反映されませんでした・・・。 これの意味が分からないのです。 A1以降と言うのは、列方向?行方向? 提示頂いたデータと表構成通りなら、こちらでは確認できています。
参考までにコメント付けて細かいところ手直し Option Explicit Sub HARU() Dim tbl Dim i As Long, j As Long '#シート2のデータをクリア Sheets("Sheet2").Cells.ClearContents ' With Sheets("Sheet1") '#繰り返し構文。シート1の最終行からCtrl+↑で止まったところの行数になるまで、2行単位で繰り返す For i = 1 To .Range("A" & .Cells.Rows.Count).End(xlUp).Row Step 2 ' '#変数tblにSplitで「、」区切りにした1次配列を入れて、Traspose関数で2次配列にする tbl = Application.Transpose(Split(.Cells(i, "A").Value, "、")) ' '#tblの2次目の配列を↑で取得したデータを残しつつ、1から2に再定義し、チームのデータを入れられるようにする ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2) ' '#繰り返し構文。2次配列にチームを入れる For j = 1 To UBound(tbl, 1) tbl(j, 2) = Left(.Cells(i + 1, "B"), 1) Next j ' '#シート2にあるデータの最終行+1から、配列分拡張したセル範囲に、tbl配列を入れる Sheets("Sheet2").Range("A" & .Cells.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl Next i End With ' '#「シート2にあるデータの最終行+1」をすると、1行目は必ず空白になるので、1行目を削除する Sheets("Sheet2").Range("A1").EntireRow.Delete End Sub (稲葉) 2014/07/10(木) 11:51
理想通りに、なりました!!
こちらのコピペミスです。大変失礼いたしました・・・。
一つ一つコメントまで記載していただいて、本当にありがとうございます。
大変勉強になりました。これからVBA位読めるようもっと勉強します。
また、何かありましたらご教授いただけると幸いです。
稲葉さん、本当に感謝です!ありがとうございました。
(HARU) 2014/07/10(木) 12:58
<Sheet1>・・・・・・・・・・・・・・
A B C D E F
1 3/1 田中、山田、川崎、町田、柴崎 (空白) 済み (空白) 神奈川
2 Xチーム
3 (行空白)
4 3/2 内村、村上、槌田 (空白) 済み (空白) 神奈川
5 ○チーム
6 (行空白)
7 3/3 土屋、鈴木、 (空白) 済み (空白) 青森
8 △チーム
9 (行空白)
10 3/4 溝口、中村、小川、宮川、近藤 (空白) 済み (空白) 青森
11 △チーム
12(行空白)
13 3/5 飯田、辻、吉田、三河 (空白) 済み (空白) 大阪
14 ○チーム
<Sheet2>・・・・・・・・・・・・・・
A列 B列
1 田中 A
2 山田 A
3 川崎 A
4 町田 A
5 柴崎 A
6 内村 B
7 村上 B
8 槌田 B
9 土屋 C
10 鈴木 C
11 溝口 C
12 中村 C
13 小川 C
14 宮川 C
15 近藤 C
16 飯田 D
17 辻 D
18 吉田 D
19 三河 D
・必要なのはSheet1のBとFの値です。
・Sheet1で、2行毎に空白が一行とCとE列に空白があります。
・「神奈川Xチーム=A」「神奈川○チー=B」「青森△チーム=C」「大阪○チーム=D」とSheet2でA〜Dに変換して表記したいです。
・「神奈川○チーム」と「大阪○チーム」は、チーム名が同じ為、頭の神奈川Or大阪でBまたはDと判定したいです。
何度も質問ばかりで申し訳ありませんが、再度ご教授いただけますと助かります。
よろしくお願いいたします。
(HARU) 2014/07/10(木) 16:50
実際にXとか○なんですか? 全角、半角、大文字、小文字含め、変換表を提示してください。 ○×の名前に関わらず、県名とチーム名が一致していれば、ABC・・・と続けて良いなら 簡単なのですが。
(稲葉) 2014/07/10(木) 16:57
チーム名は、記号やアルファベットは無く、全て漢字とひらがなです。
「神奈川翼チーム=A」「神奈川鳩チーム=B」「青森りんごチーム=C」「大阪たこ焼きチーム=D」です。
>○×の名前に関わらず、県名とチーム名が一致していれば、ABC・・・と続けて良いなら
簡単なのですが。
チーム間に空白は必要無く、続けていただいて大丈夫です。
何度もすみません。よろしくお願いします。
(HARU) 2014/07/10(木) 17:13
ではこちらでいかがでしょう? Option Explicit Sub HARU() Dim tbl Dim i As Long, j As Long, x As Long Dim dic As Object Dim ABC Dim tmp As String Set dic = CreateObject("Scripting.Dictionary") ABC = Split(",A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", ",") x = 0 '#シート2のデータをクリア Sheets("Sheet2").Cells.ClearContents ' With Sheets("Sheet1") '#繰り返し構文。シート1の最終行からCtrl+↑で止まったところの行数になるまで、3行単位で繰り返す For i = 1 To .Range("A" & .Cells.Rows.Count).End(xlUp).Row Step 3 ' '#変数tblにSplitで「、」区切りにした1次配列を入れて、Traspose関数で2次配列にする tbl = Application.Transpose(Split(.Cells(i, "B").Value, "、")) ' '#tblの2次目の配列を↑で取得したデータを残しつつ、1から2に再定義し、チームのデータを入れられるようにする ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2) ' '#繰り返し構文。2次配列にチームを入れる For j = 1 To UBound(tbl, 1) tmp = .Cells(i, "F") & "_" & .Cells(i + 1, "F") If Not dic.exists(tmp) Then x = x + 1 dic.Add tmp, ABC(x) End If tbl(j, 2) = dic.Item(tmp) Next j ' '#シート2にあるデータの最終行+1から、配列分拡張したセル範囲に、tbl配列を入れる Sheets("Sheet2").Range("A" & .Cells.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl Next i End With ' '#「シート2にあるデータの最終行+1」をすると、1行目は必ず空白になるので、1行目を削除する Sheets("Sheet2").Range("A1").EntireRow.Delete End Sub
(稲葉) 2014/07/10(木) 17:16
こんな短時間で希望通りの表が作成できるとは思っていなかったので、本当に驚きました。
ありがたいことに、コメントまで添えて頂いて、勉強になります。
何度も相談に乗っていただいて、というより何から何までお任せしてVBAまで作っていただき
ありがとうございました!!
本当に本当に感謝致します。
稲葉さん、ありがとうございました♪
(HARU) 2014/07/10(木) 18:08
教えていただいたVBAで希望通りの処理が行えていたのですが、保存して再度VBAを実行しようとすると
「実行時エラー’9’ インデックスが有効範囲にありません。」と表示され、デバッグボタンを押すと、
「 ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2) 」のコードが黄色で囲われています。
調べていたのですが、元々VBAが分かっていないので解決できませんでした。
どなたか対処方法を教えて下さい。よろしくお願いします。
(Haruharu) 2014/07/14(月) 17:37
もしかして一人のところありませんか? 下記の場合、1行目の田中さんとか。 [A]____ [B]_________________________ [C] [D] [E] [F] [1] 3月1日 田中 済み 神奈川 [2] Xチーム [3] [4] 3月2日 内村、村上、槌田 済み 神奈川 [5] ○チーム [6] [7] 3月3日 土屋、鈴木、 済み 青森 [8] △チーム [9] [10] 3月4日 溝口、中村、小川、宮川、近藤 済み 青森 [11] △チーム [12] [13] 3月5日 飯田、辻、吉田、三河 済み 大阪 [14] ○チーム
(稲葉) 2014/07/14(月) 17:52
ここの部分を > tbl = Application.Transpose(Split(.Cells(i, "B").Value, "、"))
こちらに tbl = Application.Transpose(Split(.Cells(i, "B").Value & "、", "、"))
ここの部分を > '#繰り返し構文。2次配列にチームを入れる > For j = 1 To UBound(tbl, 1)
こちらに置き換えてください。 '#繰り返し構文。2次配列にチームを入れる For j = 1 To UBound(tbl, 1) - 1
ダミーの配列を作って、ループ時に除去しています。 (稲葉) 2014/07/14(月) 18:01
Sheet1のF1「神奈川Xチーム」と、F4「神奈川○チーム」の人をSheet2でまとめて同じグループにすることはできますか?
ただし、神奈川チームに限ってグループをまとめますが、他は、まとめません
(※以下の例だとF7「大阪○チーム」と、F10「大阪△チーム」は、別グループとします。)
[A] [B] [C] [D] [E] [F] [1] 3月1日 田中 済み 神奈川 [2] Xチーム [3] [4] 3月2日 内村、村上、槌田 済み 神奈川 [5] ○チーム [6] [7] 3月3日 土屋、鈴木、 済み 大阪 [8] ○チーム [9] [10] 3月4日 溝口、中村、小川、宮川、近藤 済み 大阪 [11] △チーム [12] [13] 3月5日 飯田、辻、吉田、三河 済み 福岡 [14] □チーム
よろしくお願いします。
(Haruharu) 2014/07/14(月) 18:32
規則性があれば「簡単」に出来ますが、この表を変更出来ないのでしたらやらない方が後々 コードのメンテナンスがし易いです。
表を変更出来るなら、神奈川だけ同じチーム名に変更するか、出力されたデータを手作業で 直した方がよっぽど早いです。
>>○×の名前に関わらず、県名とチーム名が一致していれば、ABC・・・と続けて良いなら >>簡単なのですが。 >チーム間に空白は必要無く、続けていただいて大丈夫です。 このやり取りした時にスルーしましたが、この意味は「県名とチーム名が一致していれば、ABC」 というところが要点で、「チーム間に空白は必要無く」は全く関係ありません。
それでもどうしても行いたいようであれば、ありとあらゆる考えられる例外を提示してください。 一々対応出来ません。
(稲葉) 2014/07/15(火) 08:52
関数を少しかじっている程度でしたので、なかなか思った形にできず困っておりました。
が、稲葉さんにここまで理想通りの形に仕上げて頂いて本当に感謝しております。
>表を変更出来るなら、神奈川だけ同じチーム名に変更するか、出力されたデータを手作業で
>直した方がよっぽど早いです。
はい。手作業で修正致します。
最初に質問してからここまでの対応の速さに驚き、もしかすると私が思っているほど難しい事ではないのかな?
と素人考えだけで何度もお願いしてしまい、申し訳ありませんでした。
頂いたVBA活用させていただきます!何度も対応していただき、本当にありがとうございます♪
(Haruharu) 2014/07/15(火) 10:48
最初は難しかったですよ。 まず自分で組み立てて、「なぜできないか」をここで質問しました。
今回の件は理屈さえ分かっていれば簡単です。 追加したところは★印をつけておきました。 Option Explicit Sub HARU() Dim tbl Dim i As Long, j As Long, x As Long Dim dic As Object Dim ABC Dim tmp As String Dim exc As String '★ Set dic = CreateObject("Scripting.Dictionary") ABC = Split(",A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z", ",") '#例外都道府県(「、」で区切って入力 例)"神奈川、栃木" exc = "神奈川" '★ x = 0 '#シート2のデータをクリア Sheets("Sheet2").Cells.ClearContents ' With Sheets("Sheet1") '#繰り返し構文。シート1の最終行からCtrl+↑で止まったところの行数になるまで、3行単位で繰り返す For i = 1 To .Range("A" & .Cells.Rows.Count).End(xlUp).Row Step 3 ' '#変数tblにSplitで「、」区切りにした1次配列を入れて、Traspose関数で2次配列にする tbl = Application.Transpose(Split(.Cells(i, "B").Value & "、", "、")) ' '#tblの2次目の配列を↑で取得したデータを残しつつ、1から2に再定義し、チームのデータを入れられるようにする ReDim Preserve tbl(1 To UBound(tbl, 1), 1 To 2) ' '#繰り返し構文。2次配列にチームを入れる For j = 1 To UBound(tbl, 1) - 1 tmp = .Cells(i, "F") '★ If InStr(1, exc, tmp) = 0 Then '★ tmp = tmp & "_" & .Cells(i + 1, "F") '★ End If '★ If Not dic.exists(tmp) Then x = x + 1 dic.Add tmp, ABC(x) End If tbl(j, 2) = dic.Item(tmp) Next j ' '#シート2にあるデータの最終行+1から、配列分拡張したセル範囲に、tbl配列を入れる Sheets("Sheet2").Range("A" & .Cells.Rows.Count).End(xlUp).Offset(1).Resize(UBound(tbl, 1), UBound(tbl, 2)).Value = tbl Next i End With ' '#「シート2にあるデータの最終行+1」をすると、1行目は必ず空白になるので、1行目を削除する Sheets("Sheet2").Range("A1").EntireRow.Delete End Sub
理屈 Dictionaryオブジェクトは連想配列というもので、KeyとItemという2種類の値を持つことが出来ます。 Keyは一つのオブジェクトの中で、1つしか持てず、また重複するKeyの有無をExistsプロパティで簡単 に調べることが出来るます。 更に、Keyを渡すことで、Keyに対応したItemを取り出すことが出来るのが特徴です。
今回は、Keyに「都道府県名&チーム名」という一意の値を持たせ、Itemに「1から始まる連番」を振 ります。
この、「都道府県名&チーム名」を神奈川だけは「都道府県」というキーのみ割り振れば良いので、 例外を格納する変数「exc」に神奈川を入れて、InStr関数で「いま処理している都道府県がexcに含ま れているか」を調べて処理を振り分けています。
分からないことがあればいくらでも説明しますが、仕様変更しました、直してくださいは勘弁してく ださい。 (稲葉) 2014/07/15(火) 12:05
>分からないことがあればいくらでも説明しますが、仕様変更しました、直してくださいは勘弁してく
>ださい。
確かにその通りでした。最初は、近いものができないかという相談から、気がついたらまる投げでお願いばかりしていました。
あくまで、ここは質問の場であることを忘れてはいけませんでした。
また、好意でここまで対応していただいていたのに、重ね重ね失礼致しました。
再度作っていただいたVBAを、確認させていただきます。
VBAの本も購入しましたので、それも見ながらどんなふうに作られているのか勉強したいと思います。
検証結果は後日改めてご報告させていただきます。(出張中の為)
次回から分からなければ、きちんと質問という形でコメントするよう注意します。
長くなりましたが、取り急ぎ、お礼申し上げます。ありがとうございました。
(Haruharu) 2014/07/15(火) 16:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.