excel2003(vba)で御教授御願いします。

　　　　A　　　　　B　　　　　C
1　　番号　　　名前　　　タイプ
2　　qqq111　　Xさん　　　SA1
3　　qqq222　　Yさん　　　SA2
4　　aaa111　　Xさん　　　SB1
5　　111　　　　Xさん　　　SC3
6　　222　　　　Yさん　　　SC2


入力情報として上記のような3列からなる情報がエクセルに記入されていたとします。
A1,B1,C1にそれぞれ項目名(列名)があるとします。
番号111と222の人がC列に対して上記のようなタイプを保持しているとき
出力結果として下記の表をVBAにより自動発生させることを実現したいです。


　　　　A　　　　B　　　　C　　　　D　　　　E　　　　F　　　　G　　　　H　　　　I
1　　　　　　　　　　　　SA1　　　SA2　　SB1　　SB2　　　SC1　　SC2　　SC3
2　　番号　　名前
3　　111　　　Xさん　　○　　　　　　　　　○　　　　　　　　　　　　　　　　　　○
4　　222　　　Yさん　　　　　　　　○　　　　　　　　　　　　　　　　　　○


ロジックとして、
出力結果のA列は、入力情報のA列の"数字"部分です。
頭三文字：aaa,qqqは省きます。
出力結果のB列は重複している名前を一つにして出力しています。
つまり番号列は数字部分、名前はそのままでそれぞれ重複文を
圧縮して出力します。
さらに、入力タイプ列に書かれた情報通りに○をCからI列のどれかに
○を付けます。
番号と名前は可変するとします。。
また、タイプはSA1からSC3で固定でしてこの中のいづれかに該当するとします。


動作確認を行いOKとなったソースプログラムの記述を御願い致します。
以上長くなりますが、何卒宜しく御教授お願い致します。

No.2 ベストアンサー 回答者： cj_mover 回答日時： 2013/05/30 16:34

[番号]は[名前]に対する一意なＩＤ、ということなのだとして。

Option Explicit
' ' 参照設定：　　Microsoft Scripting Runtime
' ' 参照設定した場合は【ａ／２択】に代えて【ｂ／２択】をイキ
' ' シート名、セル範囲の指定は、適切に。

Sub Re8111840()
　　Const タイプ = "SA1,SA2,SB1,SB2,SC1,SC2,SC3"
　　Dim mtxS() ' 元データ　二次元配列
　　Dim mtxP() ' 出力用二次元配列
　　Dim arrT() As String ' タイプ配列
　　Dim oDictType As Object ' 【ａ／２択】
'　　Dim oDictType As Scripting.Dictionary ' 【ｂ／２択】
　　Dim oDictID As Object ' 【ａ／２択】
'　　Dim oDictID As Scripting.Dictionary ' 【ｂ／２択】
　　Dim tnR As Long ' レコード数
　　Dim tnF As Long ' 出力先フィールド数
　　Dim cnt As Long ' 出力先レコード数
　　Dim nID As Long ' 文字列を除いた番号
　　Dim i As Long

' ' タイプTable作成
　　arrT = Split(タイプ, ",")
　　tnF = UBound(arrT) + 3
　　Set oDictType = CreateObject("Scripting.Dictionary") ' 【ａ／２択】
'　　Set oDictType = New Scripting.Dictionary ' 【ｂ／２択】
　　For i = 3 To tnF
　　　　oDictType(arrT(i - 3)) = i
　　Next i

' ' 元データを二次元配列で取得
　　With Sheets("Sheet1")
　　　　mtxS() = .Range("A2:C" & .Cells(2, 1).End(xlDown).Row).Value
　　End With
　　tnR = UBound(mtxS)

' ' 出力用配列サイズを不足がないサイズで大き目に再定義
　　ReDim mtxP(1 To tnR, 1 To tnF)
　　Set oDictID = CreateObject("Scripting.Dictionary") ' 【ａ／２択】
'　　Set oDictID = New Scripting.Dictionary ' 【ｂ／２択】

' ' oDictIDはＩＤに応じた出力用配列（mtxP）の行位置(Y座標)を
' ' oDictTypeは元データ３列目[タイプ]に応じた出力用配列（mtxP）の列位置(X座標)を
　　For i = 1 To tnR
　　　　nID = PickUpNum(mtxS(i, 1))
　　　　If nID Then
　　　　　　If oDictID.Exists(nID) Then
　　　　　　　　mtxP(oDictID(nID), oDictType(mtxS(i, 3))) = "○"
　　　　　　Else
　　　　　　　　cnt = cnt + 1
　　　　　　　　oDictID(nID) = cnt
　　　　　　　　mtxP(cnt, 1) = nID
　　　　　　　　mtxP(cnt, 2) = mtxS(i, 2)
　　　　　　　　mtxP(cnt, oDictType(mtxS(i, 3))) = "○"
　　　　　　End If
　　　　　　
　　　　End If

　　Next i
　　Set oDictType = Nothing:　　Set oDictID = Nothing
　　Erase mtxS()

　　With Sheets("Sheet2")
　　　　.Cells(3, 1).Resize(cnt, tnF).Value = mtxP()
　　　　.Range("A2:B2").Value = Array("番号", "名前")
　　　　.Cells(1, 3).Resize(, tnF - 2).Value = arrT
　　End With
　　Erase arrT, mtxP()
End Sub

Private Function PickUpNum(ByVal S As String) As Long
　　Dim i As Long
　　For i = 1 To Len(S)
　　　　If IsNumeric(Mid$(S, i)) Then
　　　　　　PickUpNum = Val(Mid$(S, i))
　　　　　　Exit For
　　　　End If
　　Next i
End Function

No.1 回答者： tom04 回答日時： 2013/05/30 16:24

こんにちは！

一例です。

Sheet1のデータをSheet2に表示するようにしてみました。
Sheet2の1行目の項目、2行目の「番号」・「名前」は入力済みだとします。

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long, j As Long, k As Long, c As Range, wS1 As Worksheet, wS2 As Worksheet, myFlg As Boolean
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
Application.ScreenUpdating = False
i = wS2.Cells(Rows.Count, 1).End(xlUp).Row
If i > 2 Then
Range(wS2.Cells(3, "A"), wS2.Cells(i, "I")).ClearContents
End If
For i = 2 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
myFlg = False
For k = 1 To Len(wS1.Cells(i, 1))
If Mid(wS1.Cells(i, 1), k, 1) Like "[a-z A-Z]" Then
myFlg = True
Exit For
End If
Next k
If myFlg = False Then
Set c = wS2.Range("A:A").Find(what:=wS1.Cells(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
wS1.Cells(i, 1).Resize(1, 2).Copy wS2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
End If
End If
Next i
For k = 3 To wS2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To wS1.Cells(Rows.Count, 1).End(xlUp).Row
If InStr(wS1.Cells(i, 1), wS2.Cells(k, 1)) > 0 Then
j = WorksheetFunction.Match(wS1.Cells(i, 3), wS2.Range("1:1"), False)
wS2.Cells(k, j) = "○"
End If
Next i
Next k
Application.ScreenUpdating = True
End Sub

※　Sheet1のC列データは同番号が含まれている人に重複はない！とします。
こんなんではどうでしょうか？m（_ _）m

この回答へのお礼

ありがとうございます。
ご丁寧な回答感謝します。

お礼日時：2013/05/31 20:15