vbaで質問です

質問

初めて質問させていただきます。エクセルvbaで質問です。

Aというテーブルに名前 idという列があり名前は複数のidを持っていて名前とidは重複してるものもあります。そこから

名前が一緒でidが違うid
そのidを名前ごとに一つのセルに出力したいのですが、可能でしょうか？

かなり初心者で質問の情報もこれぐらいしか出てこないほどです。

申し訳ありませんがご教授ください。

回答No.5

AKARI0418 · ベストアンサー

ソースを解析して工夫してみてください。
ソースが少し読めればすぐに解決できるはずです。

For j = 0 To RecordSet.RecordCount - 1
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + j + 1).Value = RecordSet("ID").Value
RecordSet.MoveNext
Next j
この部分がリストを出力している部分になります個々を改造すればIDをひとつのセルにまとめることができます。
この部分を改造するために解説します。
まずRecordSetはstrSQL = "SELECT * FROM A"の実行結果が格納されています。
"SELECT * FROM A"はSQLと呼ばれる言語で、ACCESS等のデータベースエンジンとVBなどのプログラミング言語の橋渡しをしてくれます。
ここで使用しているのはSELECT構文(抽出構文)です。
SELECT 項目名 FROM テーブル名となります。
項目名の変わりに"*"を使用することで、全ての項目を抽出対称にすることができます。
"SELECT * FROM A"は"SELECT 名前, ID FROM A"おなじ意味ということになります。
要するにRecordSetにはテーブルAの全ての項目が格納されているということです。
RecordSet.Filterメソッドを使用し、ある名前のものだけを使用できるようにさらに抽出をかけています。

For j = 0 To RecordSet.RecordCount - 1
For～Nextはカウンタ使用のループ構文です、jが0からRecordSet.RecordCount - 1まで繰り返します。
RecordSet.RecordCountは字の如しですが、レコード数を照会するメソッドです。
つまり、テーブルAのレコード数処理を繰り返すということになります。

Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + j + 1).Value
は指定したワークシートの特定のセルの表示されている値を表します。
SummarySheet=シート名
ここでiは名前のリストの何人目かをあらわしています。
SummaryRow=集計開始行
今出力しようとするIDが何人目なのかおよび集計開始行がわかれば出力位置を特定できますよね。
SummaryColumn=集計開始列
jはある名前のIDのレコード数
今出力しようとするIDが何件目のIDなのかおよび集計開始列がわかれば出力位置を特定できます、ただし名前も出力しているので+1となるわけです。

ここでIDをひとつのセルにまとたいと考えて見ましょう。
修正箇所が大体イメージできますでしょうか？

とりあえず
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + j + 1).Value
はjがカウントアップしてしまうので、修正しなければいけませんよね。
出力位置は名前の隣ですので
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + 1).Value
にIDを連結したものを出力するということになります。

For j = 0 To RecordSet.RecordCount - 1
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + j + 1).Value = RecordSet("ID").Value
RecordSet.MoveNext
Next j

１回の出力ですむのでループの外に出します。

For j = 0 To RecordSet.RecordCount - 1
RecordSet.MoveNext
Next j
Worksheets(SummarySheet).Cells(i + SummaryRow,SummaryColumn + 1).Value = RecordSet("ID").Value

次に出力したいデータですが、RecordSet("ID").ValueではなくRecordSet("ID").Valueを全て連結したいものです。
連結を考えなければいけません。
連結するために変数を準備しましょう。
Dim StrJoint as string
を変数の宣言が記述されている部分に記述してください。
VBで文字列は"で囲んで表現します。 例 "abc","12","漢字"
文字列の連結は&演算子または+演算子を使用することで連結可能です。
"abc" + "def" = "abcdef"となります。

StrJointにRecordSet("ID").Valueを全て格納するためには、どうすればよいでしょうか？
もともとの処理が１セルずつIDを出力できていたことを考えると、ループの中で全てのIDを連結することができるということが創造できると思います。

For j = 0 To RecordSet.RecordCount - 1
StrJoint = RecordSet("ID").Value
RecordSet.MoveNext
Next j
Worksheets(SummarySheet).Cells(i + SummaryRow,SummaryColumn + 1).Value = RecordSet("ID").Value

こんなイメージになりますでしょうか？
しかしこれでは連結はしていないので、StrJointに格納される値がループ毎に変わっていく処理になってしまいます。
変数の連結は以下のようになります。
StrJoint = "123"
StrJoint = StrJoint & "abc"
StrJointには"123abc"が格納されています。
したがって以下のようになります。

For j = 0 To RecordSet.RecordCount - 1
StrJoint = StrJoint & RecordSet("ID").Value
RecordSet.MoveNext
Next j
Worksheets(SummarySheet).Cells(i + SummaryRow,SummaryColumn + 1).Value = RecordSet("ID").Value

これでStrJointに全てのIDを格納できます。
出力データもStrJointに変えなければだめですね。

For j = 0 To RecordSet.RecordCount - 1
StrJoint = StrJoint & RecordSet("ID").Value
RecordSet.MoveNext
Next j
Worksheets(SummarySheet).Cells(i + SummaryRow,SummaryColumn + 1).Value = StrJoint

これで目的自体は達成できると思います、実行してみて結果をご覧ください。

ひとつ問題に気づくはずです。
IDの切れ目がわからず見にくいという問題です。
理想としては
ID1,ID2,ID3,・・・・
のように出力したいですよね。

そこで連結時に","を一緒に連結すればよいと考えます。

For j = 0 To RecordSet.RecordCount - 1
StrJoint = StrJoint & RecordSet("ID").Value & ","
RecordSet.MoveNext
Next j
Worksheets(SummarySheet).Cells(i + SummaryRow,SummaryColumn + 1).Value = StrJoint

のような感じですね。
"" & "abc" & ","は"abc,"
このようなイメージで連結されていきます。

ここで再度実行してみましょう。
またがっかりされたと思います、確かに,区切りで出力され見やすくなったのですが、IDの最後にカンマが残ってしまっています。
ID1,ID2,ID3・・・・IDX,
今度は最後のカンマを消して出力するようにしましょう。
最後に出力する段階でカンマを消せればよいと考えます。
そこで文字列の部分参照を行います。
VBの部分参照関数はLEFT関数、RIGHT関数、MID関数の３種類です。
A = "abcdef"
LEFT関数は左からX文字参照したいというものです。
LEFT(A,3)は"abc"を返します。
RIGHT関数は右からX文字参照したいというものです。
RIGHT(A,3)は"def"を返します。
MID関数はX文字目からY文字参照したいというものです。
MID(2,3)は"bcd"を返します。

さて最後の文字を削るためにはLEFT関数またはMID関数を使用すればよいことがわかります。
簡単なのでLEFT関数を使用します。
LEFT(対象文字列,参照文字数)というフォーマットでしたね、
対象文字列はStrJointですね、では参照文字数は何文字なのでしょうか？
StrJointの文字数から1引いたものだというのはわかりますね。
では文字数を求めるにはLEN関数を使用します。

For j = 0 To RecordSet.RecordCount - 1
StrJoint = StrJoint & RecordSet("ID").Value & ","
RecordSet.MoveNext
Next j
Worksheets(SummarySheet).Cells(i + SummaryRow,SummaryColumn + 1).Value = LEFT(strJoint,Len(strJoint)-1)

となります。

お礼

ご教授ありがとうございました。
なんと形にできそうです。自分で組む初めてのプログラムだったので勝手がわからず質問した次第でした。

本当にありがとうございました。

回答No.4

AKARI0418

Const SummarySheet As String = "Sheet2"
Const SummaryRow As Long = 2
Const SummaryColumn As Long = 2
は出力位置を指します。
Sheet2のCells(2,2)つまり"B2"を書き出し位置としています。
Sheet2が存在しないためエラーになっていると思います。
書き出したいシート名に"Sheet2"を変更すればOKです。
Const SummarySheet As String = "書き出したいシート名"
書き出し位置もA3なら
Const SummaryRow As Long = 3
Const SummaryColumn As Long = 1
書き出し位置もG5なら
Const SummaryRow As Long = 5
Const SummaryColumn As Long = 7
といった感じです。

補足

大体やりたいことはできたのですが、idが複数のセルになってしまいます。

出力した時に一つのセルにまとめるにはどうしたらいいでしょうか？
あとidがid1　id2　id3に分かれていてそれも一つにまとめたい場合はどうしたらいいでしょうか？

度々申し訳ありませんがお願いいたします。

回答No.3

AKARI0418

先ほどのソースを使用するのでしたら、エクセルの機能であるメニューのデータ-外部データの取り込み-データの取り込みを行い、表形式にしてマクロを実行すれば実現できます。

せっかくDBなのですから、SQLを使用しての抽出をしてみてはいかがですか？
参照設定でMicrosoft ActiveX Data Objects 2.1以降を追加して実行してください。

Sub TableRead()
Const DBPath As String = "C:\Documents and Settings\Administrator\My Documents\db1.mdb"
Const SummarySheet As String = "Sheet2"
Const SummaryRow As Long = 2
Const SummaryColumn As Long = 2

Dim cn As ADODB.Connection
Dim NameRecordSet As ADODB.RecordSet
Dim RecordSet As ADODB.RecordSet
Dim strSQL As String
Dim strCriteria As String
Dim i As Long, j As Long

Set cn = New ADODB.Connection
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=" & DBPath
cn.Open
strSQL = "SELECT DISTINCT 名前 FROM A"

Set NameRecordSet = New ADODB.RecordSet
NameRecordSet.Open strSQL, cn, adOpenStatic, adLockReadOnly

strSQL = "SELECT * FROM A"
Set RecordSet = New ADODB.RecordSet
RecordSet.Open strSQL, cn, adOpenStatic, adLockReadOnly

For i = 0 To NameRecordSet.RecordCount - 1
strCriteria = "名前='" & NameRecordSet("名前").Value & "'"
RecordSet.Filter = strCriteria
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn).Value = NameRecordSet("名前").Value
For j = 0 To RecordSet.RecordCount - 1
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + j + 1).Value = RecordSet("ID").Value
RecordSet.MoveNext
Next j
RecordSet.Filter = adFilterNone
NameRecordSet.MoveNext
Next i

RecordSet.Close: Set RecordSet = Nothing
NameRecordSet.Close: Set NameRecordSet = Nothing
cn.Close
Set cn = Nothing

End Sub

補足

worksheet(summrysheetのところでエラーとなるのですがどうしたらいいでしょうか？

回答No.2

AKARI0418

基本的なやり方としては、
１．１件ずつ名前をチェックし、重複のない名前の配列を取得する。
２．名前の回数全IDをチェックし、名前の等しいデーターを抽出する。
３．リストに書き出す。
２のつど３を行うことになると思います。

基本的なやり方は勉強なさってみてください、難しくはないと思います。
参考としてあまりベターなやり方ではない方法を紹介します。
Microsoft.Scripting.Runtimeを参照設定して実行してみてください。
Dictionaryクラスを使用して、重複を排除していく方法です。

Sub Summary()
'名前列
Const NameColumn As Long = 1
'ID列
Const IDColumn As Long = NameColumn + 1
'出力先
Const SummarySheet As String = "Sheet2"
Const SummaryRow As Long = 2
Const SummaryColumn As Long = 2

'遅延バインディングの場合
'Dim NameList As object
'Microsoft.Scripting.Runtimeを参照設定すること
Dim NameList As New Scripting.Dictionary
Dim StartRow As Long
Dim EndRow As Long
Dim WorkRange As Range
Dim CheckRow As Long
Dim WorkStr() As String
Dim duplicationFlag As Boolean
Dim i As Long, j As Long
'データー開始位置
StartRow = 2

'集計範囲格納
Set WorkRange = Range(Cells(StartRow, NameColumn), _
Range(ActiveSheet.Cells(65536, IDColumn), _
ActiveSheet.Cells(65536, IDColumn)).End(xlUp))
'遅延バインディングの場合
'Set NameList = CreateObject("Scripting.Dictionary")

For i = 1 To WorkRange.Rows.Count
CheckRow = i
'すでに名前が登録されているかをチェック
If NameList.Exists(WorkRange.Cells(CheckRow, NameColumn).Value) = False Then
NameList.Add WorkRange.Cells(CheckRow, NameColumn).Value, _
WorkRange.Cells(CheckRow, IDColumn).Value
Else
'初期化
Erase WorkStr
duplicationFlag = False

'Dictionaryのアイテムを,区切りで配列に格納"a,b,c" → {"a","b","c"}
WorkStr = Split(NameList.Item(WorkRange.Cells(CheckRow, NameColumn).Value), ",")

'重複IDをチェック
For j = 0 To UBound(WorkStr) - 1
If WorkStr(j) = WorkRange.Cells(CheckRow, IDColumn).Value Then
duplicationFlag = True
Exit For
End If
Next j
'重複無しならアイテム追加,区切りで文字列連結"a,b,c"
If duplicationFlag = False Then
NameList.Item(WorkRange.Cells(CheckRow, NameColumn).Value) = _
NameList.Item(WorkRange.Cells(CheckRow, NameColumn).Value) & _
"," & WorkRange.Cells(CheckRow, IDColumn).Value
End If
End If
Next i

Set WorkRange = Nothing

'集計
'Dictionaryのアイテム数ループ
For i = 0 To NameList.Count - 1
'キー(名前)書き出し
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn).Value = NameList.Keys(i)
'初期化
Erase WorkStr
'Dictionaryのアイテムを,区切りで配列に格納"a,b,c" → {"a","b","c"}
WorkStr = Split(NameList.Item(NameList.Keys(i)), ",")
'ID書き出し
For j = 0 To UBound(WorkStr)
Worksheets(SummarySheet).Cells(i + SummaryRow, SummaryColumn + j + 1).Value = WorkStr(j)
Next j
Next i

Set NameList = Nothing
End Sub

補足

回答ありがとうございます。

すみません、エクセルからではなくmdbから取得して、名前とidを
名前 id
￣￣￣￣￣￣￣
｜
｜
｜
｜
｜

このように分けるとしたら可能でしょうか？

何度も申し訳ありません。

回答No.1

n-jun

例題を提示された方がわかりやすいかも。

補足

Aテーブル

名前 id
￣￣￣￣￣￣￣
田中 1234
田中 abcd
鈴木 4567
鈴木 ag365
佐藤 2j6

とこんな感じテーブルでそこから
田中 1234 abcd
鈴木 4567 ag365
佐藤 2j6

idを一つのセルにまとめたいのです。

あくまで例題なのでこれを応用して作りたいと思っているのですが…。

わかりづらかったらすみません。何卒お願いいたします。