ExcelのVBAについて

下記のようなシートがります。

番号をグループとして、値のみをシート２に列と行を入れ替えて転記したいのです。

０１　１　２　３　４　５　６
０２　７～１６
０３　２０～３１

このコード書く事が、検討がつかないのです。
というのは、番号は、日によって番号が増減します。

この表ですと、０１の番号に対応する値は、6個ですが、日によっては０１番号に対応する値が１０個とかになります。

丸投げで申し訳ありせんが、どのようにかくのでしょうか？
お手数ですが、ご教示お願いします。




番号　　値
01 1
01 2
01 3
01 4
01 5
01 6
02 7
02 8
02 9
02 10
02 11
02 12
02 13
02 14
02 15
02 16
03 17
03 18
03 19
03 20
03 21
03 22
03 23
03 24
03 25
03 26
03 27
03 28
03 29
03 30
03 31

No.1 ベストアンサー 回答者： tom04 回答日時： 2018/04/22 19:19

こんばんは！

元データはSheet1にあり、Sheet2に表示するとします。
尚、Sheet1の1行目は項目行でデータは2行目以降にあるという前提です。
標準モジュールです。

Sub Sample1()
Dim i As Long, j As Long
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
With Worksheets("Sheet2")
lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
If lastRow > 1 Then
Range(.Cells(2, "A"), .Cells(lastRow, "B")).ClearContents
End If
.Range("A:A").NumberFormatLocal = wS.Range("A2").NumberFormatLocal
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
For j = 2 To wS.Cells(i, Columns.Count).End(xlToLeft).Column
With .Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = wS.Cells(i, "A")
.Offset(, 1) = wS.Cells(i, j)
End With
Next j
Next i
End With
MsgBox "完了"
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

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

sheet1と同じものがsheets２にできました。

コード参考にさせてただきます

お礼日時：2018/04/22 19:25

No.2 回答者： めぐみん_ 回答日時： 2018/04/22 19:49

Sub abc()

Dim Dic As Object
Dim r As Range
Dim key

Set Dic = CreateObject("Scripting.Dictionary")

With Worksheets("Sheet1")
For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
If Not Dic.Exists(r.Text) Then Dic.Add r.Text, CreateObject("System.Collections.ArrayList")
Dic(r.Text).Add (r.Offset(, 1).Value)
Next
End With

With Worksheets("Sheet2")
.Cells.ClearContents
.Columns("A:A").NumberFormatLocal = "@"
Set r = .Range("A1")

For Each key In Dic.Keys
r.Value = key
r.Offset(, 1).Resize(, Dic(key).Count).Value = Dic(key).ToArray()
Set r = r.Offset(1)
Next
End With
Set Dic = Nothing
Set r = Nothing
End Sub

https://detail.chiebukuro.yahoo.co.jp/qa/questio …

この回答へのお礼

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

お礼日時：2018/04/22 19:52