Ｐａｇｅ 546 ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ 通常モードに戻る ┃ ＩＮＤＥＸ ┃ ≪前へ │ 次へ≫ ━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━ ▼マトリックスの作成。 杏 02/12/26(木) 13:30 ┗Re:マトリックスの作成。 Jaka 02/12/26(木) 16:57 ┗Re:マトリックスの作成。 杏 02/12/26(木) 17:58 ┗Re:マトリックスの作成。 ゆと 02/12/26(木) 20:16 ┗Re:マトリックスの作成。 杏 02/12/27(金) 9:55 ┗Re:マトリックスの作成。 ゆと 02/12/27(金) 21:10 ┗Re:マトリックスの作成。 杏 02/12/30(月) 8:42 ┗Re:マトリックスの作成。 ゆと 03/1/7(火) 1:02 ┣Re:マトリックスの作成。 Jaka 03/1/7(火) 9:15 ┃ ┗ちょっと訂正 Jaka 03/1/7(火) 9:29 ┃ ┗Re:ちょっと訂正 杏 03/1/7(火) 12:25 ┗Re:マトリックスの作成。 杏 03/1/7(火) 12:20 ┗Re:マトリックスの作成。 ゆと 03/1/8(水) 1:46 ┗Re:マトリックスの作成。 杏 03/1/9(木) 12:31 ┗Re:マトリックスの作成。 Jaka 03/1/10(金) 10:19 ┣Re:マトリックスの作成。 ゆと 03/1/13(月) 15:14 ┃ ┗Re:マトリックスの作成。 杏 03/1/15(水) 8:01 ┗Re:マトリックスの作成。 杏 03/1/15(水) 8:04 ─────────────────────────────────────── ■題名 ： マトリックスの作成。 ■名前 ： 杏 ■日付 ： 02/12/26(木) 13:30 -------------------------------------------------------------------------
| いつもお世話になっております。 さて、ここに以下のようなデータがあります。 社員コード 名前 勤務地 属性 00145 たろう 横浜 ２ 00328 はなこ 東京 １ 00221 じろう 大阪 ２ 00095 けんた 東京 ３ 00180 ひろみ 横浜 １ このデータを以下のようなマトリクスに置き換えたいのですが…。 勤務地／属性 １ ２ ３ 東京 00328 00095 はなこ けんた 横浜 00180 00145 ひろみ けんた 大阪 00221 じろう これは何かエクセルの機能で対応しているのでしょうか？それとも マクロで配置できるのでしょうか？もしマクロで配置可能でしたら 教えて頂ければ幸いです。 よろしくお願い致します。 |
| ▼杏 さん： >いつもお世話になっております。 > >さて、ここに以下のようなデータがあります。 >社員コード 名前 勤務地 属性 >00145 たろう 横浜 ２ >00328 はなこ 東京 １ >00221 じろう 大阪 ２ >00095 けんた 東京 ３ >00180 ひろみ 横浜 １ > >このデータを以下のようなマトリクスに置き換えたいのですが…。 >勤務地／属性 １ ２ ３ >東京 00328 00095 > はなこ けんた > >横浜 00180 00145 > ひろみ けんた > >大阪 00221 > じろう こんにちは。 回答ではないのですが、置換えた表の項目等に何か決まりがあるのでしょうか？ 例えば 勤務地／属性 で、東京、横浜、大阪の順番になってますが。 出てくる基準は何ですか？ その辺りも詳しく書いておかないと、答え様が無いと思いますけど。 関数の達人なら関数だけで出来ちゃうような気もするけど．．．。 |
| ▼Jaka さん： >こんにちは。 >回答ではないのですが、置換えた表の項目等に何か決まりがあるのでしょうか？ >例えば >勤務地／属性 で、東京、横浜、大阪の順番になってますが。 >出てくる基準は何ですか？ 説明不足で申し訳ありません。 勤務地と属性の欄は、既定と考えて頂ければOKです。 特に順番に基準はありません。 マトリックスに変換する時に、既定のフォームに落とし込む作業を 自動化できれば…と考えています。 よろしくお願い致します。 |
| 杏さんこんばんは。 とりあえず、元記事を読んだ時点で組んでみたのでちょっと仕様と違う かと思いますが。 いくつか疑問をあげておくと ○一つ、同一勤務地かつ、同一属性の場合はありえますか？ ○属性は1〜ｎまでの数字データですか？ ちなみに、サンプルは、同一のモノがなく、数字データということを前提 にしてあります。 データはsheet1のA列から順に並んでいるとして、sheet2に変換後の形で 出力させてるつもりです。 冗長なところとかも結構あるので、他の人に回答をいただいた方がいいかも…。 Sub Exp() Dim i%, j&, x&, y As Byte, ch_f As Byte i% = 2 With Sheets("sheet2") .Range("A1").FormulaR1C1 = "勤務地／属性" .Range("B1").FormulaR1C1 = "1" .Range("C1").FormulaR1C1 = "2" .Range("D1").FormulaR1C1 = "3" End With Do While Sheets("sheet1").Cells(i%, 1) <> "" And i% <= 21845 j& = 2 ch_f = 0 Do While Sheets("sheet2").Cells(j&, 1).Value <> "" If Sheets("sheet2").Cells(j&, 1).Value = Sheets("sheet1").Cells(i%, 3).Value Then x& = j& ch_f = 1 Exit Do End If j& = j& + 3 Loop If ch_f = 0 Then x& = j& Sheets("sheet2").Cells(j&, 1).Value = Sheets("sheet1").Cells(i%, 3).Value End If y = CByte(Sheets("sheet1").Cells(i%, 4).Value) + 1 With Sheets("sheet2").Cells(x&, y) .NumberFormatLocal = "00000" .Value = Sheets("sheet1").Cells(i%, 1) .HorizontalAlignment = xlCenter End With With Sheets("sheet2").Cells(x& + 1, y) .Value = Sheets("sheet1").Cells(i%, 2) .HorizontalAlignment = xlCenter End With i = i + 1 Loop End Sub |
| ▼ゆと さん： 返事が遅くなり、大変申し訳ありません。 今回のリストでは、ゆとさんのマクロで完璧でした。ありがとうございます！ >○一つ、同一勤務地かつ、同一属性の場合はありえますか？ 実はあります。その場合、同じ行で一段下の列に反映させたいのですが、 そうすると、マトリックスの列が拡大してしまいます。これは仕方がないと 考えています。 >○属性は1〜ｎまでの数字データですか？ これは整数値になります。 いろいろ教えて頂き、本当に勉強になります。 よろしくお願い致します。 |
| 杏さんこんばんは。 >>○一つ、同一勤務地かつ、同一属性の場合はありえますか？ >実はあります。その場合、同じ行で一段下の列に反映させたいのですが、 >そうすると、マトリックスの列が拡大してしまいます。これは仕方がないと >考えています。 > >>○属性は1〜ｎまでの数字データですか？ >これは整数値になります。 > >いろいろ教えて頂き、本当に勉強になります。 >よろしくお願い致します。 以上の条件でマクロの修正版を作ったのですが、会社に忘れてきました(^^; というわけで、本日で仕事納めだったため、回収してUPできるのは来年になり ます…(苦笑) そんなわけで、ごめんなさい。もう一度作ればいいだけなのですが、○○なので。 |
| ▼ゆと さん： >以上の条件でマクロの修正版を作ったのですが、会社に忘れてきました(^^; >というわけで、本日で仕事納めだったため、回収してUPできるのは来年になり >ます…(苦笑) >そんなわけで、ごめんなさい。もう一度作ればいいだけなのですが、○○なので。 おはようございます。 私は今日が仕事納めですが、あまりにも電車がガラガラでびっくりしてしまいました。 ゆとさん、いつもありがとうございます。 来年UPして頂けるのを楽しみに待っています。 良いお年をお迎えください。 |
| 杏さんこんばんは。 お待たせしたくせに、期待にこたえられるかはわかりませんが一応 アップしてみます。 ご期待に答えられればいいのですが… Sub Exp() Dim i%, j&, x&, y As Byte, ch_f As Byte i% = 2 Application.ScreenUpdating = False With Sheets("sheet2") .Range("A1").FormulaR1C1 = "勤務地／属性" .Range("B1").FormulaR1C1 = "1" .Range("C1").FormulaR1C1 = "2" .Range("D1").FormulaR1C1 = "3" End With Do While Sheets("sheet1").Cells(i%, 1) <> "" And i% <= 21845 j& = 2 ch_f = 0 Do While Sheets("sheet2").Cells(j&, 1).Value <> "" If Sheets("sheet2").Cells(j&, 1).Value = Sheets("sheet1").Cells(i%, 3).Value Then x& = j& ch_f = 1 Exit Do End If j& = j& + 3 Loop If ch_f = 0 Then x& = j& Sheets("sheet2").Cells(j&, 1).Value = Sheets("sheet1").Cells(i%, 3).Value End If y = CByte(Sheets("sheet1").Cells(i%, 4).Value) + 1 If Sheets("sheet2").Cells(x&, y).Value = "" Then With Sheets("sheet2").Cells(x&, y) .NumberFormatLocal = "00000" .Value = Sheets("sheet1").Cells(i%, 1) .HorizontalAlignment = xlCenter End With With Sheets("sheet2").Cells(x& + 1, y) .Value = Sheets("sheet1").Cells(i%, 2) .HorizontalAlignment = xlCenter End With Else x& = x& + 3 Do While Sheets("sheet2").Cells(x&, 1).Value = "TEMP" If Sheets("sheet2").Cells(x&, y).Value = "" Then With Sheets("sheet2").Cells(x&, y) .NumberFormatLocal = "00000" .Value = Sheets("sheet1").Cells(i%, 1) .HorizontalAlignment = xlCenter End With With Sheets("sheet2").Cells(x& + 1, y) .Value = Sheets("sheet1").Cells(i%, 2) .HorizontalAlignment = xlCenter End With ch_f = 2 Exit Do End If x& = x& + 3 Loop If ch_f <> 2 Then With Sheets("sheet2") .Range(Rows(x), Rows(x + 2)).Insert Shift:=xlDown .Cells(x&, 1).Value = "TEMP" With .Cells(x&, y) .NumberFormatLocal = "00000" .Value = Sheets("sheet1").Cells(i%, 1) .HorizontalAlignment = xlCenter End With With .Cells(x& + 1, y) .Value = Sheets("sheet1").Cells(i%, 2) .HorizontalAlignment = xlCenter End With End With End If End If i% = i% + 1 Loop For i% = 2 To Sheets("sheet2").Cells(65536, 1).End(xlUp).Row Step 3 If Sheets("sheet2").Cells(i%, 1).Value = "TEMP" Then Sheets("sheet2").Cells(i%, 1).Value = "" Next i% Application.ScreenUpdating = True End Sub |
| おはようございます。 IV列を作業列として使っています。 属性Noは、１からNまでの連番である事が条件となっています。 ダブリチェックは、していません。 Sub MMMMM() Dim CEndRow As Long, Sh1 As Worksheet, Sh4 As Worksheet, Sh4ZokuCl As Long Dim Amatch As Variant, CCel As Variant, IVZoku As String, TB() As Long Dim Sh4EndCol As Long, WriteRow As Long, CCelSave As String Set Sh1 = Worksheets("Sheet1") Set ShW = Worksheets("Sheet4") CEndRow = Sh1.Cells(Rows.Count, "C").End(xlUp).Row ShW.Range("A1").Value = "勤務地／属性" For i = 1 To Application.Max(Sh1.Range("D2:D" & CEndRow)) ShW.Cells(1, i + 1).Value = i Next Sh1.Range("IV2:IV" & CEndRow).Value = Sh1.Range("C2:C" & CEndRow).Value ShWEndCol = ShW.Cells(1, Columns.Count).End(xlToLeft).Column Do IVZoku = Sh1.Range("IV" & Sh1.Range("IV1").End(xlDown).Row).Value Set CCel = Sh1.Range("C1" & ":C" & CEndRow).Find(IVZoku, after:=Sh1.Range("C1"), LookAt:=xlWhole, MatchCase:=True) If Not CCel Is Nothing Then CCelSave = CCel.Address Do Amatch = Application.Match(CCel.Value, ShW.Columns("A"), 0) If IsError(Amatch) = True Then If ShW.Cells(Rows.Count, "A").End(xlUp).Row = 1 Then ShW.Range("A" & 2).Value = CCel.Value Else For II = 1 To ShWEndCol ReDim Preserve TB(1 To II) TB(II) = ShW.Cells(Rows.Count, II).End(xlUp).Row Next ShW.Range("A" & Application.Max(TB) + 2).Value = CCel.Value 'ShW.Range("A" & ShW.UsedRange.Rows.Count + 2).Value = CCel.Value End If End If ShWZokuCl = Application.Match(CCel.Offset(, 1).Value, ShW.Range("A1", ShW.Cells(1, ShWEndCol)), 0) If ShW.Cells(Rows.Count, "A").End(xlUp).Row > ShW.Cells(Rows.Count, ShWZokuCl).End(xlUp).Row + 1 Then WriteRow = ShW.Cells(Rows.Count, "A").End(xlUp).Row Else WriteRow = ShW.Cells(Rows.Count, ShWZokuCl).End(xlUp).Row + 1 End If ShW.Cells(WriteRow, ShWZokuCl).NumberFormatLocal = "00000" ShW.Cells(WriteRow, ShWZokuCl).Value = CCel.Offset(, -2).Value ShW.Cells(WriteRow + 1, ShWZokuCl).Value = CCel.Offset(, -1).Value Set CCel = Sh1.Range("C1" & ":C" & CEndRow).FindNext(CCel) Loop Until CCel.Address = CCelSave Sh1.Range("IV2:IV" & CEndRow).Replace What:=IVZoku, Replacement:="" Else Exit Do End If Loop Sh1.Columns("IV").Delete Erase TB Set Sh1 = Nothing Set ShW = Nothing Set CCel = Nothing End Sub |
| > Set ShW = Worksheets("Sheet4") ↓ Set ShW = Worksheets("Sheet2") ここらへんのシート名は、仕様に合わせて変えて下さい。 |
| Jakaさんありがとうございます。 おなじ属性のデータが複数ある場合にも対応してあり、 まさしく希望どおりのものとなりました。 本当にありがとうございます！ これからもよろしくお願い致します。 |
| ▼ゆと さん： > .Range(Rows(x), Rows(x + 2)).Insert Shift:=xlDown のところで、エラーがでてしまうのですが、これは ｘが何か宣言していないために起こるのでしょうか？ よろしくお願い致します。 |
| 杏さんこんばんは。 >> .Range(Rows(x), Rows(x + 2)).Insert Shift:=xlDown > >のところで、エラーがでてしまうのですが、これは >ｘが何か宣言していないために起こるのでしょうか？ >よろしくお願い致します。 ここで使用している ｘ は x& のことです。きちんと表記するのなら .Range(Rows(x&), Rows(x& + 2)).Insert Shift:=xlDown となるはずでした。 ここで用いているxの後ろの"&"は変数の型を示すためのシンボルなので xでもx&でも同様の処理が行われるはずでしたが… 確認した環境はwin2000/Excel2000 とwinXP/Excel2002 です。 |
| ▼ゆと さん： >確認した環境はwin2000/Excel2000 とwinXP/Excel2002 です。 私のExcelは97−SR1でした…。 今時こんなの使っている人いないですね。すみません。 それで、x→x&に置き換えて、マクロを走らせたのですが、どうも 同じエラーメッセージが出てしまいます。 どのようにすればよいでしょうか？ いつも親切に教えて下さってありがとうございます。 |
| 横レス失礼します。 実行状態に問題があるようです。 ゆとさんの書き方だとアクティブシートのみが対象になるようです。 たぶん、ゆとさんはSheet2をアクティブにした状態でテストされたんでしょう。 何で、こう言う状態でテストをして、このような書き方をしたのか解りませんが．．。 Sheet2をアクティブにして実行されればエラーになりません。 私だったら下のように書くけど．．．。 これならSheet1とSheet2のどちらが選択されていても挿入されました。 .Range(Rows(x&), Rows(x& + 2)).Insert Shift:=xlDown ↓ .Rows(x& & ":" & x& + 2).Insert shift:=xlDown >私のExcelは97−SR1でした…。 >今時こんなの使っている人いないですね。すみません。 私のも似たような物です。私のは、97−SR2です 2000年問題でのUP後、excel97自動再計算修正パッチって言うのを当てただけだと思う。 |
| Jaka さんこんにちは。 遅くなりましたが、フォローありがとうございます。 >実行状態に問題があるようです。 >ゆとさんの書き方だとアクティブシートのみが対象になるようです。 >たぶん、ゆとさんはSheet2をアクティブにした状態でテストされたんでしょう。 はい、去年組んだときにどうやらアクティブシートのみを対象にしていたようです。 原因は、ちょっと勘違いしてたことでした（＾＾； 杏さんごめんなさい〜。 |
| ▼ゆと さん： 返事が遅くなり大変申し訳ありませんでした。 おかげさまで、大変勉強になりました。 これからも、よろしくお願い致します。 |
| ▼Jaka さん： ありがとうございます。これで問題なく挿入されました。 もうしばらく地道にExcel97で頑張ってみようかなと思いますので、 またいろいろ教えて頂ければ幸いです。 |