[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『抽出方法』（とめきち）
すみません、抽出方法で教えて頂いても宜しいでしょうか？
Ａ Ｂ Ｃ Ｄ Ｆ Ｇ コード 県 時間 利用 時間 利用 １ 函館 ３ 送付 ２ 手書き ２ 盛岡 ２ ３ 送付 ３ 大阪 １ ３ ４ 大宮 ３ サイン ２ サイン ５ 沖縄 １ なし １ 手書き ６ 新宿 １ １ なし
上記の表があります。 これを、Ｄ・Ｇのどちらか、両方に入っているデータを抽出して、表を作りたいので
すがどうしたらいいのでしょうか？ こんな感じの表にしたいのですが・・・。
Ａ Ｂ Ｃ Ｄ Ｆ Ｇ コード 県 時間 利用 時間 利用 １ 函館 ３ 送付 ２ 手書き ２ 盛岡 ２ ３ 送付 ４ 大宮 ３ サイン ２ サイン ５ 沖縄 １ なし １ 手書き ６ 新宿 １ １ なし
どのようにしたらいいのか教えて下さい。 お願いします。
H列に作業列を作成 H2 =D2&G2 以下コピー
データ → フィルタ → オートフィルター H列の▼をクリックし （空白以外のセル）をチェック 必要であれば、別表などにコピペ
以上で如何でしょう？ （キリキ）(〃⌒o⌒)b
出来れば、上記のように表を作りたいのですが・・・。 教えて頂いたやり方ですと、行と行がつながっているので、ＤとＧの境目がわからない のですが・・・。 上記のような表は無理でしょうか？
>ＤとＧの境目がわからない 別表にコピペするとき、H列をコピーの範囲から外してしまえば良いのではないでしょうか？
>上記のような表は無理でしょうか？ もちろん可能ですよ～♪
関数がご希望でしたら、
元表がSheet1にある状態で、
Sheet2
A1 =IF(SUM(--(Sheet1!$D$1:$D$7&Sheet1!$G$1:$G$7=""))>ROW(A1),"",
IF(INDEX(Sheet1!$A$1:$G$7,SMALL(IF(Sheet1!$D$1:$D$7&Sheet1!$G$1:$G$7<>"",ROW($A$1:$A$7),""),ROW(A1)),COLUMN(A1))="","",
INDEX(Sheet1!$A$1:$G$7,SMALL(IF(Sheet1!$D$1:$D$7&Sheet1!$G$1:$G$7<>"",ROW($A$1:$A$7),""),ROW(A1)),COLUMN(A1))))
↑配列数式
上記数式を入力（又は、コピペ）後、
Ctrl + Shift + Enter で、確定。
｛ 数式 ｝となればOK。
以上で如何でしょう？ ※チョット数式が長いですね。。。
（キリキ）(〃⌒o⌒)b
会社で使っているので、月曜日に確認させて頂きます。
宜しくお願い致します。
試しに、マクロでも作成してみました～♪
標準モジュールへ
'----------------------
Sub test()
Dim MyDic As Object
Dim MyA As Variant
Dim MyR As Long, i As Long
With Worksheets("Sheet1")
MyR = .Range("A" & Rows.Count).End(xlUp).Row
MyA = .Range("A1").Resize(MyR, 7)
End With
If IsEmpty(MyA) Then: Exit Sub
Set MyDic = CreateObject("Scripting.Dictionary")
For i = 1 To MyR
If MyA(i, 4) <> "" Or MyA(i, 7) <> "" Then
MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), MyA(i, 6), MyA(i, 7))
End If
Next i
With Worksheets("Sheet2")
.Cells.ClearContents
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
.Range("B1").Resize(MyDic.Count, 6) = Application.Transpose(Application.Transpose(MyDic.items))
End With
Erase MyA
Set MyDic = Nothing
End Sub
※元データは、Sheet1 にあるものとしています。 A1 から入力してあるものとしてます。 抽出先は、Sheet2 の、A1 からにしてあります。
１）Alt + F11 を押す。 ２）挿入 → 標準モジュール ３）出てきた白い画面に、上記コードをコピペ ４）ファイル → 終了してMicrosoft Excel に戻る ５）Alt + F8 を押す。 ６）「test」を選んで実行。
（キリキ）(〃⌒o⌒)b
ありがとうございます。 何度も申し訳ないのですが、もし入力されているデータがＢ２４からの場合は、Ａ１と なっている箇所を、Ｂ２４に変更するだけで平気でしょうか？ 初心者なので、マクロが分からなくてすみません。 それと、このマクロの意味を調べるとしたらどうすれば分かりますか？
>もし入力されているデータがＢ２４からの場合は 変更してみました～
一応説明も記入してみましたが、、、 ヘルプを見ながら見てみてください ※VBAのヘルプは、インストールしないと見れませんよ～♪
Sub TEST()
Dim MyDic As Object
Dim MyA As Variant
Dim S_R As Long, L_R As Long, MyR As Long, i As Long
'↑変数の宣言
With Worksheets("Sheet1") 'Sheet1で一連の処理を開始
S_R = .Range("B24").Row 'リストの始まり「B24」の行番号を、S_Rに格納
L_R = .Range("B" & Rows.Count).End(xlUp).Row 'B列の最後の行番号を、L_Rに格納
MyR = L_R - S_R + 1 'MyR に、リストが何行あるかを格納
MyA = .Range("B24").Resize(MyR, 7) 'MyA に、「B24」から始まるリストを格納
End With '一連の処理終了
If IsEmpty(MyA) Then: Exit Sub 'MyA が、空なら処理終了
Set MyDic = CreateObject("Scripting.Dictionary") 'MyDic という辞書の作成
For i = 1 To MyR 'i 回（リストの行分）繰り返し
If MyA(i, 4) <> "" Or MyA(i, 7) <> "" Then 'リストの、4番目と7番目が空だったら次の処理へ
MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), MyA(i, 6), MyA(i, 7))
'Keyにリストの1番目を登録し、Itemにリストの2～7番目を登録
End If 'If 処理終了
Next i 'i 回数分の処理繰り返し
With Worksheets("Sheet2") 'Sheet2で一連の処理を開始
.Cells.ClearContents 'Sheet2をクリア
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
'A1 からKey の数分下に、Keyを入力
.Range("B1").Resize(MyDic.Count, 6) = Application.Transpose(Application.Transpose(MyDic.items))
'B1 からItem の数分下に、右に6分の範囲に、Itemを入力
End With '一連の処理終了
Erase MyA 'MyA の解放
Set MyDic = Nothing '辞書の解除
End Sub '処理終了
（キリキ）(〃⌒o⌒)b
キリキさん、ありがとうございました。 説明までしていただきありがとうございました。 会社で使っているのは、ヘルプがインストールされていなくて使えませんでした。 本当にありがとうございました。 また宜しくお願い致します。
もう一回お聞きしたいのですが、コピーをしてマクロを実行したら
実行時エラー１３
型が一致しません。と出てしまいました・・・。
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
ここが黄色くなっています。
項目を増やしたからでしょうか？ Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ コード 県 時間 利用 時間 利用 その他 備考
宜しくお願い致します・
◆関数による回答です！ ◆元表をSheet1とし、抽出した表をSheet2とします！ ◆Sheet1 A B C D E F G 1 コード 県 時間 利用 時間 利用 2 1 函館 3 送付 2 手書き 3 2 盛岡 2 3 送付 4 3 大阪 1 3 5 4 大宮 3 サイン 2 サイン 6 5 沖縄 1 なし 1 手書き 7 6 新宿 1 1 なし
◆Sheet2 A B C D E F G 1 コード 県 時間 利用 時間 利用 2 1 函館 3 送付 0 2 手書き 3 2 盛岡 2 0 3 送付 4 4 大宮 3 サイン 0 2 サイン 5 5 沖縄 1 なし 0 1 手書き 6 6 新宿 1 0 1 なし
◆Sheet2の式 A2=IF(ROW(A1)>SUMPRODUCT((Sheet1!$D$2:$D$100<>"")*(Sheet1!$G$2:$G$100<>"")),"",INDEX(Sheet1!A:A,100-LARGE(INDEX((Sheet1!$D$2:$D$100<>"") *(Sheet1!$G$2:$G$100<>"")*100-ROW(Sheet1!$A$2:$A$100),0),ROW(A1)))) ★下にコピー
B2=IF($A2="","",VLOOKUP(Sheet2!$A2,Sheet1!$A$2:$G$100,COLUMN(),0)) ★右・下の対象範囲にコピー（上の表では、式をE列は消去してください） (Maron)
返事が遅くなりました。。。
>もう一回お聞きしたいのですが、コピーをしてマクロを実行したら その後如何でしょうか？ Maronさんと、Hatchさんのフォローのお陰で解決していると良いのですが。
もしまだのようでしたら、もう一度こちらに連絡ください。
（キリキ）(〃⌒o⌒)b
あら･･･読み返したら、「データがB24から始まる」と書いた後に、 A～H列の項目名が提示されていたりしますね･･･ 私が提示したコードはA1セルから始まっている場合です。
>初心者なので、マクロが分からなくてすみません。 とのことから、改変を強いるのはちょっと配慮が欠けていたような気もします。
よって、お詫びするとともに、コードは削除させていただきます。m(__)m (Hatch@Excel2002)
Ａ Ｂ Ｃ Ｄ Ｆ Ｇ コード 県 時間 利用 時間 利用 となっていますがAからGとコードから利用までの数か合いませんよね。 E列は空欄ですか。 教えてください。おねがいします。 (kk)
風邪を引いてしまい、お返事が遅くなりました。 すみませんでした・・・。 Maronさん、ありがとうございました。 これは、Sheet2にコピーをすればいいのでしょうか？
キリキさん、まだ、マクロの方が解決していません・・・。 もう一度、教えて頂いても宜しいでしょうか？ ＫＫさん、今は↓のような項目になっているのでＥ列は空欄ではありません。
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ コード 県 時間 利用 時間 利用 その他 備考
空欄かどうかを調べるのは、「利用」部分ですよね？ D列 と F列 で考えています。
こんな感じで如何でしょう？
Sub TEST2()
Dim MyDic As Object
Dim MyA As Variant
Dim MyR As Long, i As Long
'↑変数の宣言
With Worksheets("Sheet1") 'Sheet1で一連の処理を開始
MyR = .Range("A" & Rows.Count).End(xlUp).Row 'MyR に、リストが何行あるかを格納
MyA = .Range("A1").Resize(MyR, 8) 'MyA に、「A1」から始まるリストを格納
End With '一連の処理終了
If IsEmpty(MyA) Then: Exit Sub 'MyA が、空なら処理終了
Set MyDic = CreateObject("Scripting.Dictionary") 'MyDic という辞書の作成
For i = 1 To MyR 'i 回（リストの行分）繰り返し
If MyA(i, 4) <> "" Or MyA(i, 6) <> "" Then 'リストの、4番目と6番目が空だったら次の処理へ
MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), MyA(i, 6), MyA(i, 7), MyA(i, 8))
'Keyにリストの1番目を登録し、Itemにリストの2～8番目を登録
End If 'If 処理終了
Next i 'i 回数分の処理繰り返し
With Worksheets("Sheet2") 'Sheet2で一連の処理を開始
.Cells.ClearContents 'Sheet2をクリア
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
'A1 からKey の数分下に、Keyを入力
.Range("B1").Resize(MyDic.Count, 7) = Application.Transpose(Application.Transpose(MyDic.items))
'B1 からItem の数分下に、右に7分の範囲に、Itemを入力
End With '一連の処理終了
Erase MyA 'MyA の解放
Set MyDic = Nothing '辞書の解除
End Sub '処理終了
（キリキ）(〃⌒o⌒)b
こんな塩梅に書き換えたらいけますワ。
'--------------------------------
Sub TEST()
Dim MyDic As Object
Dim MyA As Variant
Dim S_R As Long, L_R As Long, MyR As Long, i As Long
With Worksheets("Sheet1")
S_R = .Range("B24").Row
L_R = .Range("B" & Rows.Count).End(xlUp).Row
MyR = L_R - S_R + 1
MyA = .Range("b24").Resize(MyR, 8)
'↑に変更
'MyA = .Range("B24").Resize(MyR, 7)
End With
If IsEmpty(MyA) Then: Exit Sub
Set MyDic = CreateObject("Scripting.Dictionary")
For i = 1 To MyR
If MyA(i, 4) <> "" Or MyA(i, 6) <> "" Then
'↑に変更
'If MyA(i, 4) <> "" Or MyA(i, 7) <> "" Then
MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), _
MyA(i, 6), MyA(i, 7), MyA(i, 8))
'↑に変更
'MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), MyA(i, 6), MyA(i, 7))
End If
Next i
With Worksheets("Sheet2")
.Cells.ClearContents
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
.Range("b1").Resize(MyDic.Count, 7) = Application.Transpose(Application.Transpose(MyDic.items))
'↑に変更
'.Range("B1").Resize(MyDic.Count, 6) = Application.Transpose(Application.Transpose(MyDic.items))
End With
Erase MyA
Set MyDic = Nothing
End Sub
'（弥太郎）(〃⌒o⌒)b
'↑ に変更
'（キリキ）(〃⌒o⌒)b
プププッ！ ししょ～ったら、、、
せやけど、ししょ～ 今は、A1 からのリストに変更になってまりまんがな（笑 まぁ ここは、とめきちさんの勉強資料を作成っちゅ～ことでんな＾＾
（キリキ）(〃⌒o⌒)b
あちゃ～っ！ やってもた・・・（笑 なにもどじっぷりまで変更せんでもええのに～・・・（汗 （弥太郎）
何度も、何度もありがとうございます。 こんな塩梅に書き換えたらいけますワ。の下のマクロをコピーしてやってみたら ｓｈｅｅｔ２に出来たのですが、 D列 と F列 の空欄以外のデータも一緒に出てきて しまっています。 私のやりかたがいけないのでしょうか？ 初心者なのに、難しいことをやろうとしていることが間違っているとは思うのですが 教えていただければと思います。 お願い致します。
え？ これはSheet1のB24からIのデータ最終行を検索しE25、G25にデータがなければ ハネるっちゅうことちゃいまんのん？ それやったらご希望通りのデータが拾えてますけどなぁ・・・。 （弥太郎）
話をちょっと整理します。
１）現在の表は、下記の様になっているんですよね？ >Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ >コード 県 時間 利用 時間 利用 その他 備考
２）上記表の、A1 から、リストがありますよね？
３）D列 と F列 の空欄以外を、Sheet2 に抽出するんですよね？
以上が合っていれば、σ(^o^;)のものでやってみてください。 Sub TEST2() ってやつです＾＾
もし、上記と違うようでしたら 何が違うかを記入してみてください～♪
（キリキ）（〃⌒o⌒)b
お返事が遅くなりました。 キリキさん、弥太郎さんありがとうございました。 私が勘違いしていたみたいです。 Sub TEST2()を、コピーしたらできました。 こんな塩梅に書き換えたらいけますワ！の方をコピーしていたみたいです・・・。 ご迷惑をおかけいたしました。 何度も何度も、付き合っていただきありがとうございました。 これからも宜しくお願い致します。
何回も申し訳ないのですが、また質問をさせてください。 また、シートに変更があり、項目を追加しなくてはいけなくなってしまいました。 Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ I コード 県 時間 利用 時間 利用 その他 備考 結果
Ｉの結果が増えてしまいました。
Sub TEST2()の説明していただいた内容を見て変更してみたのですがうまくいかず
また教えて頂いてもいいでしょうか？
MyA = .Range("A1").Resize(MyR, 8)
↓
MyA = .Range("A1").Resize(MyR, 9)
MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), MyA(i, 6), MyA(i, 7), MyA(i, 8))
↓
MyDic.Add MyA(i, 1), Array(MyA(i, 2), MyA(i, 3), MyA(i, 4), MyA(i, 5), MyA(i, 6), MyA(i, 7), MyA(i, 8), MyA(i, 9))
に変更してみたのですが・・・。他に変更箇所等、教えて頂いても宜しいでしょうか？
おしぃ！！ 後、一つの変更でしたね～♪
.Range("B1").Resize(MyDic.Count, 7) = Application.Transpose(Application.Transpose(MyDic.items))
↓
.Range("B1").Resize(MyDic.Count, 8) = Application.Transpose(Application.Transpose(MyDic.items))
#Itme登録をArrayではなく、もうチョットコンパクト？リストが変更になってもいいようにするにはどうしたら良いかな～？ 誰か、おせ～てm(_ _)m ↑ 何だかできたかも～♪
とめきちさんへ
下記で対応してみてもらえます？
リストの数が変更になっても出来そうです＾＾
Sub TEST3()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant
Dim MyR As Long, i As Long, n As Long
'↑変数の宣言
With Worksheets("Sheet1") 'Sheet1で一連の処理を開始
MyR = .Range("A" & Rows.Count).End(xlUp).Row 'MyR に、リストが何行あるかを格納
MyA = .Range("A1").CurrentRegion 'MyA に、「A1」から始まるリストを格納
ReDim MyAry(1 To UBound(MyA, 2) - 1) 'MyAry にリストの2番目からの数を格納
End With '一連の処理終了
If IsEmpty(MyA) Then: Exit Sub 'MyA が、空なら処理終了
Set MyDic = CreateObject("Scripting.Dictionary") 'MyDic という辞書の作成
For i = 1 To MyR 'i 回（リストの行分）繰り返し
If MyA(i, 4) <> "" Or MyA(i, 6) <> "" Then 'リストの、4番目と6番目が空だったら次の処理へ
For n = 1 To UBound(MyA, 2) - 1 'n回（リスト2番目からの数分）繰り返し
MyAry(n) = MyA(i, n + 1) 'MyAry(n) に、リスト2番目から順に登録
Next n '繰り返し
MyDic.Add MyA(i, 1), MyAry() 'Keyにリストの1番目を登録し、Itemにリストの2～8番目を登録
End If 'If 処理終了
Next i 'i 回数分の処理繰り返し
With Worksheets("Sheet2") 'Sheet2で一連の処理を開始
.Cells.ClearContents 'Sheet2をクリア
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
'A1 からKey の数分下に、Keyを入力
.Range("B1").Resize(MyDic.Count, UBound(MyA, 2) - 1) = Application.Transpose(Application.Transpose(MyDic.Items))
'B1 からItem の数分下に、右にリスト2番目からんの数分の範囲に、Itemを入力
End With '一連の処理終了
Erase MyA, MyAry() 'MyA・MyAry の解放
Set MyDic = Nothing '辞書の解除
End Sub '処理終了
（キリキ）(〃⌒o⌒)b
キリキさんありがとうございます。 あと一つでしたか・・・。 私もお聞きしたかったのですが、シート名がｓｈｅｅｔ１とｓｈｅｅｔ２じゃなくても マクロを使える方法をお聞きしたかったのです。 週毎に、シートを変えて登録していきたいと考えていたんですが・・・。 でも、日付を項目に増やして、日付で管理すればそれは解決できるのかな？とも考えて います。
今、試してみたのですが型が一致しませんと出てしまいました。 ReDim MyAry(1 To UBound(MyA, 2) - 1) 'MyAry にリストの2番目からの数を格納 が黄色く色付けされています。 お願いいたします。
>シート名がｓｈｅｅｔ１とｓｈｅｅｔ２じゃなくても どのような Book で、どのように Sheet が増えていく仕様ですか？
>ReDim MyAry(1 To UBound(MyA, 2) - 1) 'MyAry にリストの2番目からの数を格納 >が黄色く色付けされています。 現在の表構成はどのようになっていますか？ こちらではならなかったのですが、、、
（キリキ）(〃⌒o⌒)b
今は、ｓｈｅｅｔ１とｓｈｅｅｔ２でマクロを試してみようと思って行った所
黄色く色付けされてしまいました・・・。
下記の様に記入できますか？
Sheet1 Ａ Ｂ Ｃ Ｄ Ｆ Ｇ コード 県 時間 利用 時間 利用 １ 函館 ３ 送付 ２ 手書き ２ 盛岡 ２ ３ 送付 ３ 大阪 １ ３ ４ 大宮 ３ サイン ２ サイン ５ 沖縄 １ なし １ 手書き ６ 新宿 １ １ なし
（キリキ）(〃⌒o⌒)b
Ａ Ｂ Ｃ Ｄ Ｅ Ｆ Ｇ Ｈ I コード 県 時間 利用 時間 利用 その他 備考 結果 １ 函館 ３ 送付 ２ 手書き ｸﾘｯﾌﾟ 後日 ３／７ ２ 盛岡 ２ ３ 送付 ３ 大阪 １ ３ ４ 大宮 ３ サイン ２ サイン 印なし 連絡 ３／１済み ５ 沖縄 １ なし １ 手書き ６ 新宿 １ １ なし
こんな感じになっています。
何度もすみません・・・。
う～ん、、、 σ(^o^;)のイメージしている通りなんだけどな。。。 何でだろう？？？
試しに新しいシートにで、もう一度上記「Sub TEST3()」をコピペしなおして 実行してみてもらっても良いですか？
チョイト変更してみました。
Option Base 1
Sub TEST4()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant
Dim i As Long, n As Long
'↑変数の宣言
With Worksheets("Sheet1") 'Sheet1で一連の処理を開始
If Application.CountA(.Range("A1").CurrentRegion) = 0 Then: MsgBox "リストを確認してください": Exit Sub
MyA = .Range("A1").CurrentRegion 'MyA に、「A1」から始まるリストを格納
ReDim MyAry(UBound(MyA, 2) - 1) 'MyAry にリストの2番目からの数を格納
End With '一連の処理終了
If IsEmpty(MyA) Then: Exit Sub 'MyA が、空なら処理終了
Set MyDic = CreateObject("Scripting.Dictionary") 'MyDic という辞書の作成
For i = 1 To UBound(MyA, 1) 'i 回（リストの行分）繰り返し
If MyA(i, 4) <> "" Or MyA(i, 6) <> "" Then 'リストの、4番目と6番目が空だったら次の処理へ
For n = 1 To UBound(MyA, 2) - 1 'n回（リスト2番目からの数分）繰り返し
MyAry(n) = MyA(i, n + 1) 'MyAry(n) に、リスト2番目から順に登録
Next n '繰り返し
MyDic.Add MyA(i, 1), MyAry() 'Keyにリストの1番目を登録し、Itemにリストの2～8番目を登録
End If 'If 処理終了
Next i 'i 回数分の処理繰り返し
With Worksheets("Sheet2") 'Sheet2で一連の処理を開始
.Cells.ClearContents 'Sheet2をクリア
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
'A1 からKey の数分下に、Keyを入力
.Range("B1").Resize(MyDic.Count, UBound(MyA, 2) - 1) = Application.Transpose(Application.Transpose(MyDic.Items))
'B1 からItem の数分下に、右にリスト2番目からんの数分の範囲に、Itemを入力
End With '一連の処理終了
Erase MyA, MyAry() 'MyA・MyAry の解放
Set MyDic = Nothing '辞書の解除
End Sub '処理終了
（キリキ）（〃⌒o⌒)b
試しに新しいシートにで、もう一度上記「Sub TEST3()」をコピーをしなおして実行 してみましたけど、さっきと同じで黄色くなってしまいました。 きっと、私のちょっとした事がいけないと思うのですが・・・。 それと、チョイト変更してみましたもやってみたのですが、リストを確認して下さい となってしまいました。
何度も何度もすみませんが、宜しくお願い致します。
>リストを確認して下さいとなってしまいました。 ということは、A1 からリストがある訳では無いという事になりますね？
「コード」と記入してあるのは、表のどの部分になりますか？ A1 からではなく、何処の位置から始まってますでしょうか？
（キリキ）(〃⌒o⌒)b
Ａの２４からデータを入力しています。 すみません。私が気付けば良かったことでした・・・。
コード 県 時間 利用 時間 利用 その他 備考 結果 ２４ 函館 ３ 送付 ２ 手書き ｸﾘｯﾌﾟ 後日 ３／７ ２５ 盛岡 ２ ３ 送付 ２６ 大阪 １ ３ ２７ 大宮 ３ サイン ２ サイン 印なし 連絡 ３／１済み ２８ 沖縄 １ なし １ 手書
こんな感じです・・・。 すみませんがお願いします。
これでどうだ～♪
標準モジュールへ
'----------------
Option Base 1
Sub TEST5()
Dim MyDic As Object
Dim MyA As Variant, MyAry() As Variant
Dim i As Long, n As Long
'↑変数の宣言
With ActiveSheet 'アクティブシートで一連の処理を開始
If MsgBox("抽出を開始します" & Chr(13) & Chr(13) & "シートを確認してください", _
Title:="確認してください", Buttons:=vbOKCancel) = 2 Then: MsgBox "中止します": Exit Sub
'処理を開始するかを MsgBox で確認
If Application.CountA(.Range("A24").CurrentRegion) = 0 Then: MsgBox "リストを確認してください": Exit Sub
'リストが無かったら、処理終了
MyA = .Range("A24").CurrentRegion 'MyA に、「A1」から始まるリストを格納
ReDim MyAry(UBound(MyA, 2) - 1) 'MyAry にリストの2番目からの数を格納
End With '一連の処理終了
If IsEmpty(MyA) Then: Exit Sub 'MyA が、空なら処理終了
Set MyDic = CreateObject("Scripting.Dictionary") 'MyDic という辞書の作成
For i = 1 To UBound(MyA, 1) 'i 回（リストの行分）繰り返し
If MyA(i, 4) <> "" Or MyA(i, 6) <> "" Then 'リストの、4番目と6番目が空だったら次の処理へ
For n = 1 To UBound(MyA, 2) - 1 'n回（リスト2番目からの数分）繰り返し
MyAry(n) = MyA(i, n + 1) 'MyAry(n) に、リスト2番目から順に登録
Next n '繰り返し
MyDic.Add MyA(i, 1), MyAry() 'Keyにリストの1番目を登録し、Itemにリストの2～8番目を登録
End If 'If 処理終了
Next i 'i 回数分の処理繰り返し
Worksheets.Add After:=Worksheets(Sheets.Count) '新規シートを一番後ろに作成
With Worksheets(Sheets.Count) '新規シートで一連の処理を開始
.Range("A1").Resize(MyDic.Count, 1) = Application.Transpose(MyDic.keys)
'A1 からKey の数分下に、Keyを入力
.Range("B1").Resize(MyDic.Count, UBound(MyA, 2) - 1) = Application.Transpose(Application.Transpose(MyDic.Items))
'B1 からItem の数分下に、右にリスト2番目からんの数分の範囲に、Itemを入力
End With '一連の処理終了
Erase MyA, MyAry() 'MyA・MyAry の解放
Set MyDic = Nothing '辞書の解除
End Sub '処理終了
（キリキ）（〃⌒o⌒)b 20:10 チョット修正
お返事が遅くなりました。 長々とありがとうございました。
最後にもう一つお聞きしたいのですが、もし、項目が８じゃなく１２とかに増 えてしまった場合は・・・。 MyDic.Add MyA(i, 1), MyAry()'Keyにリストの1番目を登録し、Itemにリストの 2～8番目を登録となっている所を訂正すればいいのでしょうか？
いや～ できましたか～♪ よかった～ 心配してたんですよ☆ 今回の質問の件は、試しに項目を12個に増やしてやってみてください。 項目が増えても対応できるようにしたつもりです。 もし、また何かあったら連絡ください～♪ ただ、σ(^o^;)は、 今日→休み 明日→出張 明後日→休み と、なってます。 ごめんなさいね。 （キリキ）(〃⌒o⌒)b
キリキさんありがとうございます。 試してみたのですが、増やした項目が抽出されませんでした・・・。
コード 県 時間 利用 時間 利用 その他 備考 結果 評価 ２４ 函館 ３ 送付 ２ 手書き ｸﾘｯﾌﾟ 後日 ３／７ Ａ ２５ 盛岡 ２ ３ 送付 Ｃ ２６ 大阪 １ ３ ２７ 大宮 ３ サイン ２ サイン 印なし 連絡 ３／１済み Ｂ ２８ 沖縄 １ なし １ 手書
備考までしか転機されていないのですが・・・。結果と評価で転機されません。。。 また作っていただいた、これでどうだ～♪の下のマクロをコピーすればいいんです よね？また違っていますか？ お返事が返せるときで構いませんので、宜しくお願い致します。
お待たせしました～♪
σ(^o^;)の方では抽出できました。 あっ！ 説明が足りなかったかも・・・ 今度のコードは、新しいシートに抽出しています。 その Book に 新しいシートを追加して、そこに出すようになっています。
その説明が無かったですね。。。 理由が、そうでないとするとどうしてでしょう？
（キリキ）（〃⌒o⌒)b
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.