ExcelのVBAでできますか？

質問

こんにちは。

項目1　項目2
あ　a1
あ　a2
あ　a3
あ　a4
い　b1
い　b2
い　b3
い　b4
い　b5
い　b6
い　b7

というデータがあり、これを別シートに

項目1　項目2　項目3　項目4　項目5　項目6　項目7　項目8
あ　a1　a2　a3　a4
い　b1　b2　b3　b4　b5　b6　b7

と表示させたいです。

が、VB初心者なので「あ」のところまでしかできませんでした。
実際のデータは「い」から下もずーっとあるので変数などを使わなくてはいけないのでしょうが、よくわかりません。

どうしたらうまくいくでしょうか？

ここまで自分でやってみました。
Range("A2").Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="あ"
Range("A2").Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
Sheets("Sheet1").Select
Range("B2:B15").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(1).Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

回答No.7

pauNed · ベストアンサー

こんにちは。Wendy02さん。
#3...というと私のコードですか？
これはスピード度外視してますから、きっと大量データには向かないと思います。
実際に10,000件ですと40秒くらいかかるのではないかしらん？
Wendy02さんのコードのほうが速いですし、
値だけでよければ#5のimogasiさんのコードがおススめです>質問者のlehuaさんへ。

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

回答No.6

Wendy02

#2のWendy02です。

#その方法は、否定はしませんが、ランクが上がります。よほど、大量でないと、この方法はあまり使いませんね。

この発言は、無視してください。私のコードと#3さんのコードを比較すると、今回の場合は、単に二つだけを比較すると、#3のコードのほうが速いし、ご質問者さんの書いている内容にも則しています。内容的にも、私のほうがややこしいです。(失礼しました。）

だいたい、10,000件のデータぐらいにすると、はっきりと違いが分かります。

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

回答No.5

imogasi

Sub test05()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet3")
Set sh2 = Worksheets("Sheet4")
'--初期設定
k = 1 'Sheet2のスタート行
j = 2 'Sheet2のスタ－ト列B列
sh2.Cells(k, "A") = sh1.Cells(1, "A")
sh2.Cells(k, j) = sh1.Cells(1, "B")
'---
For i = 2 To sh1.Range("A65536").End(xlUp).Row
If sh1.Cells(i, "A") = sh1.Cells(i - 1, "A") Then '直前行と比較
j = j + 1
Else
k = k + 1 '下の行に行く
sh2.Cells(k, "A") = sh1.Cells(i, "A")
j = 2 'B列に復帰

End If
sh2.Cells(k, j) = sh1.Cells(i, "B")
Next i

End Sub
例データ
Sheet3　A1:B１４
あ a1
あ a2
あ a3
あ a4
い b1
い b2
い b3
い b4
い b5
い b6
い b7
う c1
う c2
う c3
結果
Sheet4
A1:H3
あ a1 a2 a3 a4
い b1 b2 b3 b4 b5 b6 b7
う c1 c2 c3

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

回答No.4

web2525

回答出てるようですが一応作ったので、コピー元シート選択した状態で実行してください。

Sub marabikae()

Range("A1").Select
motosheet = ActiveSheet.Name

Do
mozi = ActiveCell.Value　　　‛元データの文字収納
kaisi = ActiveCell.Offset(0, 1).Address　　　’コピー元データの先頭

Do　　　　　　　　　　　　　　　　　　　’文字が変わるまでループ
ActiveCell.Offset(1, 0).Select　　　　　’してます
Loop Until ActiveCell.Value <> mozi　　 ’

syuuten = ActiveCell.Offset(-1, 1).Address　’データ終点

Range(kaisi, syuuten).Copy　　　’コピー範囲選択

Sheets("Sheet2").Select　　　　 ’範囲を行列入れ替えて貼り付け
Range("B65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

’文字データ貼り付け
Range("A65535").End(xlUp).Offset(1, 0).Value = mozi　

Sheets(motosheet).Select

Loop Until ActiveCell.Value = ""　’データがなくなるまで上記繰り返し

Sheets("Sheet2").Select　　　　　　’コピー先の体裁の変更
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp

End Sub

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

回答No.3

pauNed

こんにちは。
元コードのAutoFilterを使うセンでいくと、以下のような感じでしょうか。

Sub sample()
　　Dim ws As Worksheet '新規出力Sheet用
　　Dim r As Range 'データ範囲
　　Dim i As Long 'Loopカウンタ

　　'新規Sheet追加。変数wsに格納
　　Set ws = Sheets.Add
　　'データ範囲を変数rに格納【■■■実際のSheet名に変更必要■■■】
　　Set r = Sheets("sheet1").Range("A1").CurrentRegion
　　'一般機能でいう[フィルタオプション]でA列の値を重複せずにwsへ抜き出す。
　　r.Columns("A").AdvancedFilter Action:=xlFilterCopy, _
　　　　　　　　　　　　　　　　　CopyToRange:=ws.Range("A1"), _
　　　　　　　　　　　　　　　　　Unique:=True
　　'抜き出した値を順にLoop
　　For i = 2 To ws.Range("A65536").End(xlUp).Row
　　　　'AutoFilterをかけて、B列の見出し以外のデータを[コピー][行列入替][貼り付け]
　　　　r.AutoFilter Field:=1, Criteria1:=ws.Cells(i, 1).Value
　　　　r.Columns("B").Resize(r.Rows.Count - 1).Offset(1).Copy
　　　　ws.Cells(i, 2).PasteSpecial Paste:=xlAll, Transpose:=True
　　Next i
　　r.AutoFilter
　　'新規Sheetの列数分、見出し項目をセット。（元データA1が"項目1"前提）
　　With ws.Range("A1")
　　　　.AutoFill Destination:=.Resize(1, .CurrentRegion.Columns.Count)
　　End With

　　'SetしたObject型変数を破棄
　　Set r = Nothing
　　Set ws = Nothing
End Sub

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

回答No.2

Wendy02

こんばんは。

>Selection.AutoFilter Field:=1, Criteria1:="あ"

オートフィルタを使うと難しくなります。オートフィルタの場合は、一旦、Criteria 用のデータを抽出しなければならなくなるからです。その方法は、否定はしませんが、ランクが上がります。よほど、大量でないと、この方法はあまり使いませんね。

通常は、A列が、「並べ替え」が済んだものとして、進めていくのが簡単です。
だから、A列のデータもB列のデータも空白行がないということが前提です。

なるべく、元の雰囲気を壊さずに作ってみました。

Sub TestMacro2()
Dim i As Long
Dim NewSheet As Worksheet
Dim buf As String
Dim Start As Long

With ActiveSheet
Set NewSheet = Worksheets.Add　'新しいシート

Application.ScreenUpdating = False
For i = 2 To .Range("A65536").End(xlUp).Row
　If buf = "" Then
　　buf = .Cells(i, 1).Value　'先頭文字を確保
　　Start = i
　End If
　If .Cells(i + 1, 1).Value <> buf Then　'次のセルと比較
　　　 .Range(.Cells(Start, 2), .Cells(i, 2)).Copy
　　　 NewSheet.Range("A65536").End(xlUp).Offset(1).Value = buf
　　　 NewSheet.Range("B65536").End(xlUp).Offset(1).PasteSpecial _
　　　 Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
　　　 Start = i + 1 '先頭データの更新
　　　 buf = ""
　End If

Next i
Application.CutCopyMode = False
'項目数の代入
With NewSheet.Range("A1").CurrentRegion.Rows(1)
　 .FormulaLocal = "=""項目""" & "&COLUMN()"
　 .Cells.Value = .Cells.Value
End With
Application.ScreenUpdating = True
Set NewSheet = Nothing
End With

End Sub

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

回答No.1

Nigun

すみません。補足を要求します。

1.1列目は"あ","い"といった文字列なのか？
2.1列目の並び順は"あ","い","あ"・・・といった用に順番がバラバラになる事はないか？
以上2点を教えて下さい。

お礼

遅くなりまして申し訳ありません。解決しました。ありがとうございました。

補足

補足ありがとうございます。
1.文字列ではありません。表示形式は標準です。
2.順番がバラバラになることはありません。
どうぞよろしくお願いします。