こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

投稿日時 - 2007-01-12 18:34:51

QNo.2661460

すぐに回答ほしいです

質問者が選んだベストアンサー

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

投稿日時 - 2007-01-15 12:59:05

お礼

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

投稿日時 - 2010-04-20 17:38:54

ANo.7

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

-広告-
-広告-

回答(7)

ANo.6

#2のWendy02です。

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

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

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

投稿日時 - 2007-01-13 11:53:26

お礼

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

投稿日時 - 2010-04-20 17:37:43

ANo.5

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:B14
あa1
あa2
あa3
あa4
いb1
いb2
いb3
いb4
いb5
いb6
いb7
うc1
うc2
うc3
結果
Sheet4
A1:H3
あa1a2a3a4
いb1b2b3b4b5b6b7
うc1c2c3

投稿日時 - 2007-01-12 23:27:57

お礼

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

投稿日時 - 2010-04-20 17:36:35

ANo.4

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


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

投稿日時 - 2007-01-12 21:05:55

お礼

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

投稿日時 - 2010-04-20 17:35:54

ANo.3

こんにちは。
元コードの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

投稿日時 - 2007-01-12 20:55:41

お礼

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

投稿日時 - 2010-04-20 17:35:19

ANo.2

こんばんは。

>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

投稿日時 - 2007-01-12 20:38:05

お礼

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

投稿日時 - 2010-04-20 17:34:32

ANo.1

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

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

投稿日時 - 2007-01-12 18:40:52

補足

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

投稿日時 - 2007-01-12 18:41:25

お礼

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

投稿日時 - 2010-04-20 17:34:01

-広告-
-広告-

あなたにオススメの質問

-広告-
-広告-