| |
▼ドカ さん：
>マクロのでは、定型のデータ フォームでないと対応できないので、今回質問してみました。
ですから、私が申し上げた手作業の操作をマクロ記録して、それをお化粧直しすればよろしいかと思いますが
以下、一例です。
Sheet1のデータをSHeet2に転記しています。
Sub sample1()
Dim x As Long
Dim w As Long
Dim j As Long
Dim sh As Worksheet
Dim c As Range
Application.ScreenUpdating = False
Set sh = Sheets("Sheet2") '転記シート
sh.Cells.ClearContents '転記シートをクリア
With Sheets("Sheet1") '元シート
x = .Cells(1, .Columns.Count).End(xlToLeft).Column '元シートの列数
w = x + 2 '作業列開始列番号
'元シートの作業列に元シートのA列の一意の値を抽出
.Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=.Cells(1, w), Unique:=True
If (x - 1) * (.Cells(1, w).CurrentRegion.Rows.Count - 1) > .Columns.Count Then
MsgBox "転記するには項目の桁数が多すぎます"
Else
.Cells(1, w + 1).Value = .Cells(1, w).Value '抽出用タイトル
'抽出領域 抽出すべきタイトルをセット
.Cells(1, w + 3).Resize(, x - 1).Value = .Cells(1, 2).Resize(, x - 1).Value
'一意の値を順に取り出して、転記シートに転記
j = 1 '転記シートの転記列。最初は 1。
For Each c In .Range(.Cells(2, w), .Cells(.Rows.Count, w).End(xlUp))
.Cells(2, w + 1).Value = c.Value '抽出条件セット
'この値に対するデータを抽出
.Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Cells(1, w + 1).Resize(2), _
CopyToRange:=.Cells(1, w + 3).Resize(, x - 1), Unique:=False
'転記シートに転記
With .Cells(1, w + 3).CurrentRegion
sh.Cells(1, j).Value = c.Value
sh.Cells(2, j).Resize(.Rows.Count, .Columns.Count).Value = .Value
j = j + .Columns.Count '次の転記列ポジション
End With
Next
End If
.Cells(1, w).CurrentRegion.Clear '作業域クリア
.Cells(1, w + 3).CurrentRegion.Clear '作業域クリア
End With
sh.Select
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "処理終了しました"
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
