Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9807 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【25308】重複データを一行にまとめる さくら 05/5/27(金) 14:41 質問[未読]
【25310】Re:重複データを一行にまとめる Hirofumi 05/5/27(金) 19:49 回答[未読]
【25312】Re:重複データを一行にまとめる ponpon 05/5/27(金) 20:31 発言[未読]
【25314】Re:重複データを一行にまとめる だるま 05/5/27(金) 21:52 回答[未読]
【25369】Re:重複データを一行にまとめる さくら 05/5/30(月) 9:21 お礼[未読]
【25308】重複データを一行にまとめる
質問  さくら  - 05/5/27(金) 14:41 -
引用なし
パスワード
   初めて質問します。色々なHPで投稿している人がないか探してみたのですが解決しませんでした。誰かわかる方、よろしくお願いします。

例えば以下のようなデータがあったとします。

A　　　　　　　B　　　
鉛筆　　　　　三菱
消しゴム　　　シード　
ペン　　　　　シャープ
鉛筆　　　　　まっくす
鉛筆　　　　　さくら
消しゴム　　　デミ

データは千件を超えます。
B列には重複データはありません。（本物のデータはアルファベット付社員番号なのです）

これを下記のように変換したいのです。

A　　　　　　　B　　　　　　C　　　　　　　D
鉛筆　　　　　三菱　　　　　まっくす　　　さくら　　　　
消しゴム　　　シード　　　　デミ
ペン　　　　　シャープ

列は１０列ぐらいにしかならないです。

実際にしたいことっていうのは同じチームの人を一行にまとめたいのです。

解る方よろしくお願いします。
【25310】Re:重複データを一行にまとめる
回答  Hirofumi  - 05/5/27(金) 19:49 -
引用なし
パスワード
   'データがSheet1のA1から有るとします
'結果をSheet2のA1から出力します

Option Explicit

Public Sub Sample()

　　Dim i As Long
　　Dim lngRows As Long
　　Dim lngMax As Long
　　Dim vntData As Variant
　　Dim vntResult As Variant
　　Dim dicIndex As Object
　　Dim strProm As String
　　
　　'データListの先頭A1を指定
　　With Worksheets("Sheet1").Cells(1, "A")
　　　　'A列の行数を取得
　　　　lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
　　　　If lngRows <= 0 Then
　　　　　　strProm = "データが有りません"
　　　　　　GoTo Wayout
　　　　End If
　　　　'A列、B列を配列に取得
　　　　vntData = .Resize(lngRows, 2).Value
　　End With
　　
　　'Dictionaryオブジェクトのインスタンスを取得
　　Set dicIndex = CreateObject("Scripting.Dictionary")
　　
　　With dicIndex
　　　　'データ配列の最終行まで繰り返し
　　　　For i = 1 To lngRows
　　　　　　'DictionaryにA列の値が有った場合
　　　　　　If .Exists(vntData(i, 1)) Then
　　　　　　　　'Dictionaryの項目を結果配列に取得
　　　　　　　　vntResult = .Item(vntData(i, 1))
　　　　　　　　'結果配列のIndexの上限+1を取得
　　　　　　　　lngMax = UBound(vntResult) + 1
　　　　　　　　'結果配列を拡張
　　　　　　　　ReDim Preserve vntResult(lngMax)
　　　　　　　　'結果配列にB列の値を追加
　　　　　　　　vntResult(lngMax) = vntData(i, 2)
　　　　　　　　'結果配列をDictionaryの項目に再登録
　　　　　　　　.Item(vntData(i, 1)) = vntResult
　　　　　　Else
　　　　　　　　'結果配列を確保
　　　　　　　　ReDim vntResult(1)
　　　　　　　　'結果配列にA列、B列の値を代入
　　　　　　　　vntResult(0) = vntData(i, 1)
　　　　　　　　vntResult(1) = vntData(i, 2)
　　　　　　　　'結果配列をDictionaryに登録
　　　　　　　　.Add vntData(i, 1), vntResult
　　　　　　End If
　　　　Next i
　　　　'DictionaryのKeyを全て配列に取得
　　　　vntData = .Keys
　　End With
　　
'　　Application.ScreenUpdating = False
　　
　　'出力シートのA1を指定
　　With Worksheets("Sheet2").Cells(1, "A")
　　　　'Key（A列の値）全てに就いて繰り返し
　　　　For i = 0 To UBound(vntData)
　　　　　　'Dictionaryの項目を結果配列に取得
　　　　　　vntResult = dicIndex.Item(vntData(i))
　　　　　　'結果配列のIndexの上限+1を取得
　　　　　　lngMax = UBound(vntResult) + 1
　　　　　　'結果配列をシートに出力
　　　　　　.Offset(i).Resize(, lngMax).Value = vntResult
　　　　Next i
　　End With
　　
'　　Application.ScreenUpdating = True
　　
　　'Dictionaryオブジェクトのインスタンスを破棄
　　Set dicIndex = Nothing

　　strProm = "処理が完了しました"
　　
Wayout:
　　
　　Beep
　　MsgBox strProm
　　
End Sub
【25312】Re:重複データを一行にまとめる
発言  ponpon  - 05/5/27(金) 20:31 -
引用なし
パスワード
   さくらさん。Hirofumiさん。こんばんは。
HirofumiさんのDictionaryにはかないませんが、
（まだ、Dictionaryは、会得していない）
一応私も作ったので、
フィルタオプションとオートフィルタでやってみました。

>データは千件を超えます。
オートフィルタだから時間がかかると思います。

試してみてください。
1行目には、項目が入っているものとします。

Sub test()
　　Dim myTbl As Range
　　Dim myR As Range
　　Dim myVal As Variant
　　
　　Application.ScreenUpdating = False
　　Set myTbl = Worksheets("sheet1").Range("A1").CurrentRegion
　　Set myR = Worksheets("sheet1").Range("D1")
　
　　'A列のユニークな値をD列に書き出す。
　　myTbl.Columns(1).AdvancedFilter xlFilterCopy, copytorange:=myR, unique:=True
　　myVal = Range("D2", Range("D65536").End(xlUp)).Value
　　
　　'オートフィルターで抽出sheet2に転記
　　For i = 1 To UBound(myVal, 1)
　　　 myTbl.AutoFilter field:=1, Criteria1:=myVal(i, 1)
　　　 Range("B2", Range("B65536").End(xlUp)).Copy
　　　 With Worksheets("sheet2")
　　　　 .Range("A1:B1").Value = Worksheets("sheet1").Range("A1:B1").Value
　　　　 .Range("A65536").End(xlUp).Offset(1, 0).Value = myVal(i, 1)
　　　　 .Range("B65536").End(xlUp).Offset(1, 0).PasteSpecial _
　　　　　Paste:=xlPasteAll, Transpose:=True
　　　 End With
　　　 myTbl.AutoFilter
　　Next
　　Application.CutCopyMode = False
　　Application.ScreenUpdating = True
End Sub
【25314】Re:重複データを一行にまとめる
回答  だるま WEB  - 05/5/27(金) 21:52 -
引用なし
パスワード
   こんにちは

以前同様の質問に答えた時のコードがありましたのでよろしければどうぞ。^d^

条件
・元データはアクティブシートのA1から
（A列で並べ替えがされている。これがNGならボツですが。）
・出力先は新規シートを挿入してそこに

Sub 縦横並べ替え()
　　Dim myRange As Range
　　Dim Key As Variant
　　Dim myCell As Range
　　Dim myVal As Variant
　　Dim rngDest As Range
　　
　　Set myRange = Range("A1").CurrentRegion
　　Set rngDest = Worksheets.Add.Range("A1")
　　
　　Key = ""
　　For Each myCell In myRange.Columns(1).Cells
　　　　myVal = myCell.Offset(, 1).Value
　　　　If myCell.Value <> Key Then
　　　　　　Key = myCell.Value
　　　　　　Set rngDest = rngDest.Offset(1)
　　　　　　With rngDest
　　　　　　　　.Value = Key
　　　　　　　　.Offset(, 1).Value = myVal
　　　　　　End With
　　　　Else
　　　　　　With rngDest
　　　　　　　　.End(xlToRight).Offset(, 1).Value = myVal
　　　　　　End With
　　　　End If
　　Next
　　
　　Set myRange = Nothing
　　Set myCell = Nothing
　　Set rngDest = Nothing
　　
End Sub
【25369】Re:重複データを一行にまとめる
お礼  さくら  - 05/5/30(月) 9:21 -
引用なし
パスワード
   みなさんありがとうございました。
解決です。
昨年、目がちかちかするぐらい手作業を繰り返したので
大助かりです。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9807 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free