Excelでお尋ねしたい事があります。

質問

エクセルのデータを下記のようにするのに
良い方法があれば教えて下さい。

　　 A　　 B　　　　　　　　 A　　 B　　 C　　 D　
1　AAA　100　　　　　　1　AAA　100　101　102
2　AAA　101　　⇒　　 2　BBB　100　101　102
3　AAA　102　　　　　　3 CCC 100 101　102
4　BBB　100　　　　　
5　BBB　101
6　BBB　102
7　CCC　100
8　CCC　101
9　CCC　102

A列にある同一のデータを一行にして
B列のデータを一行にした列に持っていく作業です。

現在は、A列にある同一データのB列をコピー。
行列を入れ替えて貼り付け。
B列が空いた所を行事削除しています。

このデータが何千とありまして…
延々とコピー、貼り付け、削除。
をしています。

何か良い方法があれば教えて下さい。
よろしくお願いします。

回答No.8

Nayuta_X

それでは、以前のコードを全て削除して、下記をコピーして貼り付けてください。　結果待っています。
Sub 並べ替え() ' 改善1
Dim Data

Sheet_Name1 = ActiveSheet.Name
Sheet_Name2 = "TEST"

Range("A1").Activate
ActiveCell.CurrentRegion.Select
vy = ActiveWindow.RangeSelection.EntireRow.Count
Range("A1").Select

On Error GoTo ErrorHandler

Application.ScreenUpdating = False

j = 0

For Y = 1 To vy
Data = Range("A1").Offset(j, 0).Value
'
If Data = "" Then
Range("A1").Select
Application.ScreenUpdating = True
If Sheet_Name2 = "TEST" Then
End
Else
Application.DisplayAlerts = False
Sheets(Sheet_Name2).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

MsgBox "処理が終了しました。", vbOKOnly

End
End If
End If

Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter

Selection.AutoFilter Field:=1, Criteria1:="=" & Data

Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
myRow = 0

For Each myArea In Selection.Areas
myRow = myRow + myArea.Rows.Count
Next

If Y = 1 Then
Range(Cells(1, 2), Cells(vy, 2)).Select
Selection.Copy
Sheets.Add
Range("A1").Select
Sheet_Name2 = ActiveSheet.Name
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Else
Range(Cells(2, 2), Cells(vy, 2)).Select
Selection.Copy
Worksheets(Sheet_Name2).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
End If
Worksheets(Sheet_Name1).Select

If myRow - 1 >= 2 Then
Range(Cells(j + 2, 1), Cells(vy, 2)).Select
Selection.Delete Shift:=xlUp
End If

Selection.AutoFilter Field:=1
Selection.AutoFilter

Worksheets(Sheet_Name2).Select
Range(Cells(1, 1), Cells(1, myRow)).Select
Selection.Cut

Worksheets(Sheet_Name1).Select

Range("B1").Offset(j, 0).Select
ActiveSheet.Paste

j = j + 1
Next Y

Range("A1").Select
Application.ScreenUpdating = True

ErrorHandler:
Select Case Err

Case Is <> 0
MsgBox "ERROR NO. " & Err.Number & vbCrLf & Err.Description, vbOKOnly + vbExclamation
End
End Select

End Sub

お礼

ご回答ありがとうございます。

感動です。
結果は完璧でした。
Nayuta_Xさんのおかげで助かりました。

何十時間もかかっていた事が
これですぐ終わりました。
マクロすごいです。

何も知らない初心者にご丁寧に教えていただき
感謝の気持ちでいっぱいです。

Nayuta_Xさん。
本当にありがとうございました。

回答No.7

Nayuta_X

ANo.6に対しての一部修正です。
例　BBB　100　が、一つのみ時のデータが、連続している場合作業がうまく出来ないバグを修正しました。下記を参考にしてください。
結果報告待っています。　　　　

If myRow - 1 >= 2 Then '2070124修正
Range(Cells(j + 2, 1), Cells(vy, 2)).Select
Selection.Delete Shift:=xlUp
End If

Selection.AutoFilter Field:=1
Selection.AutoFilter

Worksheets(Sheet_Name2).Select
Range(Cells(1, 1), Cells(1, myRow)).Select '20070124修正
Selection.Cut

お礼

ANo.6,ANo.7と回答ありがとうございます。
トライしようと思ったのですが
ANo.6　差し替えるコード
ANo.7　修正コード

どこでどうするのかわかりません……
一応似たようなコードを見つけて
差し替えたり、修正したりしてみたのですが
うまくいきません…

ご丁寧に回答していただいたのに
勉強不足で大変申し訳ないです。

お時間ある時にでもご回答お願いします。
すいません。

回答No.6

Nayuta_X

一応2000pcs位Dataを作成して(漢字もひらがなも　いろいろ混ぜて)Testしました。
下記部分を入れ替えて　Test　してください。
For Y = 1 To vy
Data = Range("A1").Offset(j, 0).Value

If Data = "" Then
Range("A1").Select
Application.ScreenUpdating = True
If Sheet_Name2 = "TEST" Then
End
Else
Application.DisplayAlerts = False
Sheets(Sheet_Name2).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

MsgBox "処理が終了しました。", vbOKOnly

End
End If
End If

Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter

Selection.AutoFilter Field:=1, Criteria1:="=" & Data

Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
myRow = 0

For Each myArea In Selection.Areas
myRow = myRow + myArea.Rows.Count
Next

If Y = 1 Then
Range(Cells(1, 2), Cells(vy, 2)).Select
Selection.Copy
Sheets.Add
Range("A1").Select
Sheet_Name2 = ActiveSheet.Name
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Else

Range(Cells(2, 2), Cells(vy, 2)).Select
Selection.Copy
Worksheets(Sheet_Name2).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
End If

Worksheets(Sheet_Name1).Select

If myRow >= 2 Then
Range(Cells(j + 2, 1), Cells(vy, 2)).Select
Selection.Delete Shift:=xlUp
End If

Selection.AutoFilter Field:=1
Selection.AutoFilter

Worksheets(Sheet_Name2).Select
Range(Cells(1, 1), Cells(1, j + myRow)).Select
Selection.Cut

Worksheets(Sheet_Name1).Select

Range("B1").Offset(j, 0).Select
ActiveSheet.Paste

j = j + 1
Next Y

回答No.5

Nayuta_X

A列は「ひらがな　漢字　数字」などが交じっているのですが
それがうまくいかない原因になっているのでしょうか？
*

ひらがな　漢字　数字が、原因みたいです。

修正方法を検討しますので、いましばらく　時間を下さい。

回答No.4

Nayuta_X

このテキスト(書き込み)では、横幅に制限があり　途中で切られて(分割)しまったようです。
下記コードは、横一列(横長)につなげて　トライして下さい。
MsgBox "ERROR NO. " & Err.Number & vbCrLf & Err.Description, vbOKOnly + vbExclamation

また、セル　B1にデータが、ない場合(空白時)は、
Range("B1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
を
Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
に変更して、見てください。

もし、解らないときは、遠慮なく　質問して下さいね。
では、頑張って!!。

お礼

ご回答ありがとうございます。
コードを横一列（横長）につなげたら
エラーは解消されました。

すごいです。マクロ！
感動しました。

ですが、うまくいく部分と
うまくいかない部分が出てきてしまいました。

　 　 A　　 B　　　　　　　　
1　AAA　 100　　　　　　
2　AAA　 101　　　　
3　AAA　 102

A列は「ひらがな　漢字　数字」などが交じっているのですが
それがうまくいかない原因になっているのでしょうか？
B列は95%ぐらいが数字で、5%ぐらいは数字と漢字が交じっているのがあります。

遠慮なく質問して下さい。と言っていただいたので
遠慮なく質問してしまいました。
すいません。

ご回答いただければ幸いです。

回答No.3

Nayuta_X

マクロを使用する方法をまとめました。(初心者用です。)
これだと、データの数にもよりますが、かなり時間が短縮されますよ。
個人用マクロ　ブックの作成方法
表示⇒ツールバー⇒VisualBasic(ここにチェックを入れる)
ツールバーに　セキュリティの文字の左側に　三角と丸の記号が見えます。この丸をクリックするとマクロの記録の画面が出ます。つぎにマクロの保存先の文字をこの画面から探し個人用マクロ　ブックを指定します。
つぎにOKをクリックすると　小さな画面が出ますのでこの中にある四角ボタンを押して終了します。
個人用マクロ　ブックの参照方法
ツール⇒マクロ⇒Visual　Basic Editorを選択する。
Visual　Basic Editorが、起動して、左上にVBAProject(Personal.XLS)の文字が見えますので、この文

字をクリックします。
右側に下記の如く　コードが、現れますので、
Sub Macro1()
'
' Macro1 Macro
' マクロ記録日 : 2007/1/20 ユーザー名 :
'
End Sub

この(上の)コードを全て削除します。　そして、下記コードを貼り付けて、上書き保存します。
この後は、　セキュリティの文字の左側に　三角と丸の記号から三角をクリックすると
マクロ名と保存先が、表示されます。　[この画面で、並べ替え の文字が見えないときは、
開いているすべてのブックを選択します。] 並べ替えを選択して　実行ボタンを押すと　処理が開始
されます。　注意　マクロのセキュリティは、中にして下さい。高とか最高に設定するとマクロが、使用
出来ません。マクロを使用しない時は、高とか最高に設定して良いです。

以下は、コードです。

Sub 並べ替え()

Sheet_Name1 = ActiveSheet.Name
Sheet_Name2 = "TEST"

Range("A1").Activate
ActiveCell.CurrentRegion.Select
Vy = ActiveWindow.RangeSelection.EntireRow.Count
Range("A1").Select

On Error GoTo ErrorHandler

Application.ScreenUpdating = False

j = 0

For Y = 1 To Vy - 1
Data = Range("A1").Offset(Y - 1, 0).Value

If Data = "" Then
Range("A1").Select
Application.ScreenUpdating = True
If Sheet_Name2 = "TEST" Then
End
Else
Application.DisplayAlerts = False
Sheets(Sheet_Name2).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

MsgBox "処理が終了しました。", vbOKOnly

End
End If
End If

Selection.AutoFilter
Columns("A:A").Select
Selection.AutoFilter

Selection.AutoFilter Field:=1, Criteria1:="=" & Data

Range("B1").CurrentRegion.SpecialCells(xlCellTypeVisible).Select
myRow = 0

For Each myArea In Selection.Areas
myRow = myRow + myArea.Rows.Count
Next

j = j + 1

If Y = 1 Then
Range(Cells(1, 2), Cells(myRow + 10, 2)).Select
Selection.Copy
Sheets.Add
Range("A1").Select
Sheet_Name2 = ActiveSheet.Name
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Else

Range(Cells(j, 2), Cells(myRow + 10, 2)).Select
Selection.Copy
Worksheets(Sheet_Name2).Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
End If

Worksheets(Sheet_Name1).Select

Range(Cells(j + 1, 1), Cells(myRow + 10, 2)).Select

Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=1
Selection.AutoFilter

Worksheets(Sheet_Name2).Select
Range(Cells(1, 1), Cells(1, myRow)).Select
Selection.Copy

Worksheets(Sheet_Name1).Select

Range("B1").Offset(Y - 1, 0).Select
ActiveSheet.Paste
Next Y

Range("A1").Select
Application.ScreenUpdating = True

ErrorHandler:
Select Case Err

Case Is <> 0
MsgBox "ERROR NO. " & Err.Number & vbCrLf & Err.Description, vbOKOnly +

vbExclamation
End
End Select

End Sub

お礼

お忙しい中、ご回答ありがとうございます。
私がマクロを知らないばっかりに
ご丁寧にご説明いただいて大変恐縮です。

私の方でご説明いただいたやり方で
やってみたのですが…

下記のコードが赤く表示され

MsgBox "ERROR NO. " & Err.Number & vbCrLf & Err.Description, vbOKOnly +

コンパイルエラー:
構文エラー

と表示されたのですが
私のコピーミスでしょうか？
それとも他に何か原因があるのでしょうか？
もし、よろしければご回答お願い致します。
失礼します。

回答No.2

north_2nd

データ　→　フィルタ　→　オートフィルタ
A列のプルダウンからお好みのデータを指定する
B列のデータをコピーする
別のシートに形式を選択して貼り付けの行列変換をする。

ってのでどうでしょう。

A列の種類がいっぱい有るのなら、これをマクロ化するのが楽かな。汎用性を持たせるとめんどそうですが。

お礼

お忙しい中
ご回答ありがとうございました。

データ　→　フィルタ　→　オートフィルタ
A列のプルダウンからお好みのデータを指定する
B列のデータをコピーする
別のシートに形式を選択して貼り付けの行列変換をする。

こちらのやり方で今やってみています。

補足

ちなみにA列の種類がいっぱい有ります。
同一データの数も変則的です。
マクロの事は全然わかりません。
もし、初心者でも出来そうでしたら
教えて下さい。

回答No.1

syunmaru

エクセルの場合は、マクロ処理が利用できます。

マクロをご存知でしたら、試してみてください。

お礼

お忙しい中
ご回答ありがとうございます。

マクロ…わかりません。
もし、よろしければ
お時間がある時にでも教えて下さい。

ありがとうございました。