[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『横を縦にする方法』（SEP）
お世話になります。
下記F1より右に都道府県があり、それぞれの
数字がF2より右に入っています。
それをFの列に都道府県を入れ、G列に数量を入れるように
入れ替えるVBAを組んでいただけませんか。
ちなみに項目は500列あります。
A B C D E F G H I J K 1 性別 スタイル サイズ 手段 区分 北海道 青森 秋田 山形 岩手 宮城 2 男性 帽子 XSサイズ 車 親子 1 3 男性 帽子 Sサイズ 車 親子 4 男性 帽子 Mサイズ 車 親子 1 5 男性 帽子 Lサイズ 車 親子 2 6 男性 帽子 XLサイズ 車 親子 7 女性 帽子 XSサイズ 車 親子 1 8 女性 帽子 Sサイズ 車 親子 9 女性 帽子 Mサイズ 車 親子 4 10 女性 帽子 Lサイズ 車 親子 1 11 女性 帽子 XLサイズ 車 親子 4 1
A B C D E F G 1 性別 スタイル サイズ 手段 区分 北海道 2 男性 帽子 XSサイズ 車 親子 北海道 1 3 男性 帽子 Sサイズ 車 親子 北海道 4 男性 帽子 Mサイズ 車 親子 北海道 5 男性 帽子 Lサイズ 車 親子 北海道 6 男性 帽子 XLサイズ 車 親子 北海道 7 女性 帽子 XSサイズ 車 親子 北海道 8 女性 帽子 Sサイズ 車 親子 北海道 9 女性 帽子 Mサイズ 車 親子 北海道 10 女性 帽子 Lサイズ 車 親子 北海道 11 女性 帽子 XLサイズ 車 親子 北海道 4 12 男性 帽子 XSサイズ 車 親子 青森 13 男性 帽子 Sサイズ 車 親子 青森 14 男性 帽子 Mサイズ 車 親子 青森 1 15 男性 帽子 Lサイズ 車 親子 青森 16 男性 帽子 XLサイズ 車 親子 青森 17 女性 帽子 XSサイズ 車 親子 青森 18 女性 帽子 Sサイズ 車 親子 青森 19 女性 帽子 Mサイズ 車 親子 青森 20 女性 帽子 Lサイズ 車 親子 青森 21 女性 帽子 XLサイズ 車 親子 青森 22 男性 帽子 XSサイズ 車 親子 秋田 23 男性 帽子 Sサイズ 車 親子 秋田 24 男性 帽子 Mサイズ 車 親子 秋田 25 男性 帽子 Lサイズ 車 親子 秋田 26 男性 帽子 XLサイズ 車 親子 秋田 27 女性 帽子 XSサイズ 車 親子 秋田 28 女性 帽子 Sサイズ 車 親子 秋田 29 女性 帽子 Mサイズ 車 親子 秋田 4 30 女性 帽子 Lサイズ 車 親子 秋田 31 女性 帽子 XLサイズ 車 親子 秋田 32 男性 帽子 XSサイズ 車 親子 山形 33 男性 帽子 Sサイズ 車 親子 山形 34 男性 帽子 Mサイズ 車 親子 山形 35 男性 帽子 Lサイズ 車 親子 山形 2 36 男性 帽子 XLサイズ 車 親子 山形 37 女性 帽子 XSサイズ 車 親子 山形 38 女性 帽子 Sサイズ 車 親子 山形 39 女性 帽子 Mサイズ 車 親子 山形 40 女性 帽子 Lサイズ 車 親子 山形 41 女性 帽子 XLサイズ 車 親子 山形 42 男性 帽子 XSサイズ 車 親子 岩手 43 男性 帽子 Sサイズ 車 親子 岩手 44 男性 帽子 Mサイズ 車 親子 岩手 45 男性 帽子 Lサイズ 車 親子 岩手 46 男性 帽子 XLサイズ 車 親子 岩手 47 女性 帽子 XSサイズ 車 親子 岩手 48 女性 帽子 Sサイズ 車 親子 岩手 49 女性 帽子 Mサイズ 車 親子 岩手 50 女性 帽子 Lサイズ 車 親子 岩手 51 女性 帽子 XLサイズ 車 親子 岩手 1 52 男性 帽子 XSサイズ 車 親子 宮城 53 男性 帽子 Sサイズ 車 親子 宮城 54 男性 帽子 Mサイズ 車 親子 宮城 55 男性 帽子 Lサイズ 車 親子 宮城 56 男性 帽子 XLサイズ 車 親子 宮城 57 女性 帽子 XSサイズ 車 親子 宮城 1 58 女性 帽子 Sサイズ 車 親子 宮城 59 女性 帽子 Mサイズ 車 親子 宮城 60 女性 帽子 Lサイズ 車 親子 宮城 1 61 女性 帽子 XLサイズ 車 親子 宮城
＜ 使用 Excel：Excel2007、使用 OS：unknown ＞
Sub test()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim r As Range
Dim t As Range
Dim v As Range
Set sh1 = Worksheets("Sheet1") '元データシート
Set sh2 = Worksheets("Sheet2") '転記先シート
Application.ScreenUpdating = False
sh2.UsedRange.ClearContents
sh1.Range("A1:E1").Copy sh2.Range("A1")
sh2.Range("F1").Value = "都道府県"
sh2.Range("G1").Value = "個数"
Set t = Intersect(sh1.Range("A2:E" & Rows.Count), _
sh1.Range("A1").CurrentRegion)
For Each r In sh1.Range("F1", sh1.Range("F1").End(xlToRight))
t.Copy sh2.Range("A" & Rows.Count).End(xlUp).Offset(1)
Set v = sh2.Range("F" & Rows.Count).End(xlUp).Offset(1) _
.Resize(t.Rows.Count)
v.Value = r.Value
v.Offset(, 1).Value = r.Offset(1).Resize(t.Rows.Count).Value
Next
Application.ScreenUpdating = True
End Sub
こんな感じでしょうか？
（ウッシ） 2016/09/21(水) 20:50
ベタベタのコードですが。
Sub Sample()
Dim v As Variant
Dim x As Long
Dim j As Long
Dim i As Long
Dim dist As String
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1").CurrentRegion '★元シートの表領域
With .Resize(.Rows.Count - 1).Offset(1)
ReDim v(1 To .Rows.Count * (.Columns.Count - 5), 1 To 7)
For j = 6 To .Columns.Count
dist = .Parent.Cells(1, j).Value
For i = 1 To .Rows.Count
x = x + 1
v(x, 1) = .Cells(i, 1).Value
v(x, 2) = .Cells(i, 2).Value
v(x, 3) = .Cells(i, 3).Value
v(x, 4) = .Cells(i, 4).Value
v(x, 5) = .Cells(i, 5).Value
v(x, 6) = dist
v(x, 7) = .Cells(i, j).Value
Next
Next
End With
End With
With Sheets("Sheet2") '★転記シート
.Cells.ClearContents
Sheets("Sheet1").Range("A1:E1").Copy .Range("A1")
.Range("A2").Resize(UBound(v, 1), UBound(v, 2)).Value = v
.Select
End With
End Sub
（β） 2016/09/21(水) 21:14
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.