人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

Excelの質問です。おそらくVBAに関連します。(関数でできたら嬉しいですが・・・)
以下のようなデータから(その下のような)2軸のマトリクス表を自動で作成する方法を教えてください。


あああ | 1,500円 | 2007/3/22
いいい | 8,300円 | 2008/2/18
ううう | 2,400円 | 2008/3/4
えええ | 7,900円 | 2009/5/12
おおお | 5,100円 | 2008/4/25


横軸にA(0?2,000円)、B(2,001?6,000円)、C(6,001?9,999円)
縦軸に1(?2007/12/31)、2(2008/1/1?2008/12/31)、3(2009/1/1?)


例えば、あああ は A1 の位置に、
いいい は C2 の位置にプロット(記入?)されるようにしたいです。
(というか、こういうことはできるのでしょうか?)


よろしくお願いします。


●質問者: ysfm
●カテゴリ:コンピュータ
✍キーワード:A1 Excel VBA データ プロット
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● Mook
●27ポイント ベストアンサー

まだ仕様が把握しきれていませんが、とりあえず不明な点は推測でやってみました。


ただしセルを追記していくのは面倒なので、とりあえずセルを追加せず一つのセルの中で改行で

追加しています。

目的上、これでは役に立たないということでしたら、後ほど改訂しますがたぶん夕方以降になります。

Option Explicit

Sub myProt()
 Const NAME_COL = "C"
 Const PRICE_COL = "H"
 Const DATE_COL = "J"
 
 Const priceList = "2000,6000,9999"
 Const yearList = "2007,2008,2009"
 
 
 Dim i%, r%, c%, p%, y%
 
 Dim dataWS As Worksheet
 Dim tableWS As Worksheet
 
 Set dataWS = ActiveSheet
 Set tableWS = Worksheets.Add(before:=Worksheets(1))
 
 Dim lastRow As Long
 lastRow = dataWS.Range(NAME_COL & Rows.Count).End(xlUp).Row
 
 Dim pArray, yArray
 pArray = Split(priceList, ",")
 yArray = Split(yearList, ",")
 
 For i = 2 To lastRow '★ 1行目はタイトル行目として2行から開始
 r = 2
 For y = LBound(yArray) To UBound(yArray)
 If Year(dataWS.Cells(i, DATE_COL).Value) <= CLng(yArray(y)) Then
 Exit For
 Else
 r = r + 1
 End If
 Next
 
 c = 2
 For p = LBound(pArray) To UBound(pArray)
 If dataWS.Cells(i, PRICE_COL).Value <= CLng(pArray(p)) Then
 Exit For
 Else
 c = c + 1
 End If
 Next
 
 If tableWS.Cells(r, c).Value = "" Then
 tableWS.Cells(r, c).Value = dataWS.Cells(i, NAME_COL).Value
 Else
 tableWS.Cells(r, c).Value = tableWS.Cells(r, c).Value & vbNewLine & dataWS.Cells(i, NAME_COL).Value
 End If
 Next

 Columns("A:A").ColumnWidth = 26
 Columns("B:D").ColumnWidth = 15
 Dim pp As Long
 For p = LBound(pArray) To UBound(pArray)
 tableWS.Cells(1, p + 2).Value = Format(pp, "##,##") & "?" & Format(pArray(p), "##,##")
 pp = pArray(p) + 1
 Next
 
 For y = LBound(yArray) To UBound(yArray)
 tableWS.Cells(y + 2, "A").Value = Format(DateSerial(yArray(y), 1, 1), "yyyy/mm/dd") & "?" _
 & Format(DateSerial(yArray(y), 12, 31), "yyyy/mm/dd")
 Next
End Sub
◎質問者からの返答

ありがとうございます。

少し放り込んでみて研究してみます。

うまくいきましたらコメントにてご報告します。


2 ● Baku7770
●26ポイント

関数でできますよ。

まず、元のデータの前3列程入れます。A、B、C列とします。

A列には横軸の値が算出できるように、B列には縦軸の値が算出できるように(後述)します。C列には[=A&B]として例えばA1とかC3を算出できるようにします。

集計表は別シートでA列に2行目から1、2、3…(ちゃんと文字型にして下さい)と並んでいるとし、1行目にはB列からA、B、C…と並んでいるとして

B2に以下のように記述します。

[=IF(ISERROR(VLOOKUP(B$1&$A2,Sheet1!$C$1:$D$8,2,FALSE)),"",VLOOKUP(B$1&$A2,Sheet1!$C$1:$D$8,2,FALSE))]

これをコピペすると計算できるようになります。シート名と範囲は調整してください。

さて横軸と縦軸の算出ですがIF文を使って求めるもよいでしょうし、VLOOKUP関数で算出しても良いでしょう。くれぐれも縦軸を文字型にすることをお忘れなく。

◎質問者からの返答

ありがとうございます。

こちらも試してみます。


3 ● Mook
●27ポイント

内容は全く変更していませんが、コメントを追加しました。

Option Explicit

Sub myProt()
'★ データ列の定義
 Const NAME_COL = "C"
 Const PRICE_COL = "H"
 Const DATE_COL = "J"
 
'★ 分析範囲の定義
'--- 価格の分類:小さい順に記載すること
 Const priceList = "2000,6000,9999"
'--- 年の分類:小さい順に記載すること
 Const yearList = "2007,2008,2009"
 
 
 Dim i%, r%, c%, p%, y%
 
 Dim dataWS As Worksheet
 Dim tableWS As Worksheet
 
'★ 結果用として新規シートを先頭に作成
 Set dataWS = ActiveSheet
 Set tableWS = Worksheets.Add(before:=Worksheets(1))
 
'★ 名前列の最終行を取得
 Dim lastRow As Long
 lastRow = dataWS.Range(NAME_COL & Rows.Count).End(xlUp).Row
 
'★ 解析用に配列を作成
 Dim pArray, yArray
 pArray = Split(priceList, ",")
 yArray = Split(yearList, ",")
 
'★★★ 解析処理
'--- i はデータシートの行
'--- c, r は結果シートの列(column)と行(row)
 For i = 2 To lastRow '★ 1行目はタイトル行目として2行から開始
'★ 日付行の計算
 r = 2
 For y = LBound(yArray) To UBound(yArray)
  '--- 年とデータ配列を比較して位置を求める
 If Year(dataWS.Cells(i, DATE_COL).Value) <= CLng(yArray(y)) Then
 Exit For
 Else
 r = r + 1
 End If
 Next
 
'★ 価格列の計算
 c = 2
 For p = LBound(pArray) To UBound(pArray)
  '--- 価格とデータ配列を比較して位置を求める
 If dataWS.Cells(i, PRICE_COL).Value <= CLng(pArray(p)) Then
 Exit For
 Else
 c = c + 1
 End If
 Next
 
'★ 結果の記入
 If tableWS.Cells(r, c).Value = "" Then
 tableWS.Cells(r, c).Value = dataWS.Cells(i, NAME_COL).Value
 Else
 tableWS.Cells(r, c).Value = tableWS.Cells(r, c).Value & vbNewLine & dataWS.Cells(i, NAME_COL).Value
 End If
 Next

'★★★ 結果シートの整形
 Columns("A:A").ColumnWidth = 26
 Columns("B:D").ColumnWidth = 15
 
'★ 結果シートのタイトル列の表示:A列の表示
 Dim pp As Long
 For p = LBound(pArray) To UBound(pArray)
 tableWS.Cells(1, p + 2).Value = Format(pp, "##,##") & "?" & Format(pArray(p), "##,##")
 pp = pArray(p) + 1
 Next
 
'★ 結果シートのタイトル行の表示:1行目の表示
 For y = LBound(yArray) To UBound(yArray)
 tableWS.Cells(y + 2, "A").Value = Format(DateSerial(yArray(y), 1, 1), "yyyy/mm/dd") & "?" _
 & Format(DateSerial(yArray(y), 12, 31), "yyyy/mm/dd")
 Next
End Sub
◎質問者からの返答

ありがとうございます。

いろいろ調べながらコードを解読していました。

なんとかこれを元に応用できるよう試行錯誤してみます。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ