[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『横を縦にする方法』(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.