[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『リスト一括変換につきまして』(飛翔鯨)
お世話になっております。
VBA初心者です。宜しくご教授下さい。
A B C name rank stage 1 a AA 1 2 b AB 1 3 c AA 5 4 d AC 4 5 e AB 2 6 f AA 1 7 g AD 1
・
・
・
というリストがあります。これを下記のように
VBAにより一括変換したいのです。
rank stage AA AB AC AD 1 a b g f 2 e 3 4 d 5 c
・
・
・
これをなんというのか。。。
マトリクス変換と言うのでしょうか、このような変換ができるコードをお教え下さい。
< 使用 Excel:Excel2013、使用 OS:Windows10 >
とりあえずサンプルを書きますが、項目をソートしておきながら、stageには重複があるとか、とても面倒なデータとレイアウトなので、コーディングしやすい出力レイアウトに変えています。 これが駄目ならば、ご自身で全部考えてください。 それでも、考え方の参考くらいにはなるでしょう。
Sub test() Dim AR As Object Dim DICX As Object Dim DICY As Object Dim wk1 As Worksheet Dim wk2 As Worksheet Dim cw As String Dim i As Long
Set AR = CreateObject("System.Collections.ArrayList") Set DICX = CreateObject("Scripting.Dictionary") Set DICY = CreateObject("Scripting.Dictionary") Set wk1 = Sheets("Sheet1") Set wk2 = Sheets("Sheet2")
wk2.Cells.ClearContents
AR.Clear For i = 2 To wk1.Cells(wk1.Rows.Count, "B").End(xlUp).Row cw = wk1.Cells(i, "B").Text If Not AR.Contains(cw) Then AR.Add cw End If Next i AR.Sort wk2.Range("B1").Resize(1, AR.Count) = AR.toarray For i = 0 To AR.Count - 1 DICX.Add AR(i), i + 2 Next i
AR.Clear For i = 2 To wk1.Cells(wk1.Rows.Count, "C").End(xlUp).Row cw = wk1.Cells(i, "C").Text If Not AR.Contains(cw) Then AR.Add cw End If Next i AR.Sort wk2.Range("A2").Resize(AR.Count, 1) = WorksheetFunction.Transpose(AR.toarray) For i = 0 To AR.Count - 1 DICY.Add AR(i), i + 2 Next i
For i = 2 To wk1.Cells(wk1.Rows.Count, "A").End(xlUp).Row wk2.Cells(DICY(wk1.Cells(i, "C").Text), DICX(wk1.Cells(i, "B").Text)) = Trim(wk2.Cells(DICY(wk1.Cells(i, "C").Text), DICX(wk1.Cells(i, "B").Text)) & " " & wk1.Cells(i, "A").Value) Next i End Sub (???) 2018/06/11(月) 11:46
Option Explicit
Sub List2Matrix()
Dim rngOld As Range Dim rngNew As Range Dim rngTmpe As Range Dim ixMax As Long Dim ixCol As Long Dim ixRow As Long Dim c As Range
Set rngOld = Worksheets("Sheet3").Range("A1").CurrentRegion Set rngTmpe = Worksheets("Sheet4").Range("A1")
'表頭の作成 rngOld.Columns(2).Copy rngTmpe With rngTmpe.CurrentRegion .RemoveDuplicates Columns:=1, Header:=xlYes .Copy .Cells(2, 2).PasteSpecial Transpose:=True End With '表側の作成 ixMax = WorksheetFunction.Max(rngOld.Columns(3)) With rngTmpe(3, 2) .Cells(1).Value = 1 .Resize(ixMax).DataSeries Step:=1, Stop:=ixMax End With rngTmpe.EntireColumn.Delete '作成したマトリックス表のセル範囲の取得 With Worksheets("Sheet4").Range("A2").CurrentRegion Set rngNew = Intersect(.Cells, .Offset(1, 1)) End With
'転記する名前のセル範囲 With rngOld Set rngTmpe = Intersect(.Columns(1), .Offset(1)) End With 'マトリックス表へ転記 For Each c In rngTmpe With WorksheetFunction ixCol = .Match(c.Offset(, 1), rngNew.Rows(0), 0) ixRow = .Match(c.Offset(, 2), rngNew.Columns(0), 0) End With With rngNew(ixRow, ixCol) If Len(.Value) > 0 Then .Value = .Value & "・" & c.Value Else .Value = c.Value End If End With Next End Sub (まっつわん) 2018/06/11(月) 13:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.