エクセル マクロ 別シートへ自動転記

質問

お世話になります。

エクセルで元データシート（一覧表シート）からアルファベット毎に自動で別シートに転記したいのでですがマクロをどうやって作ればいいでしょうか？（出来ればファイルを開けた時に自動更新してほしいのですが。。）

基準になるのはローマ字でかかれている部品名で、それをアルファベットごとのシートに自動に転記されるようにしたいです。データはどんどん追加されていきます。

元データは以下のとおりです。
*データはB5セルから始まっています。

　部品名　　詳細　　金額　　・・・
　A56785 ねじ　　￥30　　　高田(株)
　B13575 棒　　　\500 安田
C59975 柵 \200 鈴木(株) 　

以上よろしくお願いします。

回答No.4

noname#196225 · ベストアンサー

jinjin020さんはバックアップはとられていましたか？
大変申し訳ないのですが、前回のマクロの不具合は非常に致命的で、
最悪の場合マクロを組み込んだエクセルのデータのほとんどが失われてしまったかもしれません。
原因は、再読み込み時に番号の割り振りが変わることを考慮していませんでした。
その不具合を修正し、要望どおりのソースを作りましたので、マクロを組み込む前にバックアップをとり、お試しください。
（幅変更のため、少々処理時間がかかるかもしれません）
---------------------------------------------------------------

Dim LName As String
Const Prefix As String = "" ' Page_A～Zの26シートが出力されます
Const SearchTarget As String = "部品名" '「部品名」と書いてあるセルの真下から空白セルまでを検索対象にします。
Const CopyColumnNumber As Integer = 0 ' 0は元のページの書式でコピーします。そのほかは相対値
Const CopyRowNumber As Integer = 0 ' 0は元のページの書式でコピーします。そのほかは相対値
Dim RAsc As Integer
Dim BaseCol As Integer
Dim BaseRow As Integer
Dim Sheet_ As Object
Dim Pgn(2 To 27) As Integer ' 整理番号

kb = -1
For k = 1 To Worksheets.Count - kb
If Worksheets.Count - kb < k Then Exit For
If Len(Worksheets.Item(k).Name) > 1 Then
If kb >= 0 Then
Worksheets.Item(k).Move , Worksheets.Item(Worksheets.Count)
Else
Worksheets.Item(k).Move Worksheets.Item(1)
End If
kb = kb + 1
If kb > 0 Then k = k - 1
End If
Next k
Worksheets.Item(1).Select

'ワークシートが非対応なら終了
Set Sheet_ = Worksheets.Item(1).Cells
If Sheet_.Find(SearchTarget) Is Nothing Then Exit Sub
BaseCol = Sheet_.Cells.Find(SearchTarget).Column
BaseRow = Sheet_.Cells.Find(SearchTarget).Row

'ワークシートが既に構成されていたら、初期処理を飛ばす
For i_ = 1 To Worksheets.Count
If Len(Worksheets.Item(i_).Name) = Len(Prefix) + 1 Then
LName = Left(LCase(Worksheets.Item(i_).Name), Len(Prefix))
RAsc = Asc(Right(UCase(Worksheets.Item(i_).Name), 1))
If LName = LCase(Prefix) And RAsc >= Asc("A") And RAsc <= Asc("Z") Then Exit For
End If
Next i_
If i_ = Worksheets.Count + 1 Then
Worksheets.Add Null, Worksheets.Item(1), 26
For i = 1 To 26
Worksheets.Item(i + 1).Name = Prefix + Chr(i + Asc("A") - 1)
Next i
Else
'過去の情報書き込み領域をクリア
For i = 1 To 26
Worksheets.Item(i + 1).Range(Cells(BaseRow + CopyRowNumber, BaseCol + CopyColumnNumber).Address, Cells(65536, 256).Address).Clear
Next i
End If
'書式をコピー
jmax = 0
Do While (Sheet_(BaseRow, BaseCol + jmax) <> "")
For i = 1 To 26
Sheet_(BaseRow, BaseCol + jmax).Copy Worksheets.Item(i + 1).Cells(BaseRow + CopyRowNumber, BaseCol + jmax + CopyColumnNumber)
Next i
jmax = jmax + 1
Loop
'各情報をセルに割り振り
i = 0
Do While (Sheet_(BaseRow + i, BaseCol) <> "")
LName = Sheet_.Cells(BaseRow + i, BaseCol)
RAsc = Asc(Left(UCase(LName), 1)) - Asc("A")
If RAsc >= 0 And RAsc <= 25 Then
Pgn(RAsc + 2) = Pgn(RAsc + 2) + 1
For j = 0 To jmax - 1
Sheet_(BaseRow + i, BaseCol + j).Copy Worksheets.Item(RAsc + 2).Cells(BaseRow + Pgn(RAsc + 2) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Next j
End If
i = i + 1
Loop
i = i - 1
For k = 1 To 26
For j = 0 To jmax
If Pgn(k + 1) > 0 Then
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Sheet_(BaseRow + i, BaseCol + j).Copy Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber) = ""
End If
Next j
Next k
'行幅・列幅コピー
For k = 1 To Worksheets.Count
For i = 1 To 256
Worksheets.Item(k).Cells(1, i).ColumnWidth = Sheet_.Cells(1, i).ColumnWidth
Next i
Next k

補足

毎回ご回答ありがとうございます＾＾とても助かっています。バックアップはとってありましたのでデータは大丈夫です！
早速、新しく作っていただきましたマクロで試してみました。一度目は完璧に動作しましたが、データを追加してマクロを実行するとやはり固まってしまいました。”いくつかのマクロが失われる可能性がありますが実行しますか？”とテロップがでてきました。

私が言っているようなマクロは無理があるのでしょうか？？どうすればいいのかご教示お願いいたします！（＿＿　本当にすみません！

回答No.5

noname#196225

だめでしたか・・・
いろいろ状況を試したのですが、申し訳ありませんが自分の環境では
不具合が起きてくれず、よってどこが悪いのか分かりかねる状態です。
（仮に仕分けする前の元の名前がアルファベットや数字1文字だったとしても、エラーが起こるだけで固まるはずはないですし・・・）
お使いのバージョンと自分のバージョン（私はoffice2000です）が違うことが問題かもしれませんし、そもそもシートのスタイルが全く想定外なのかもしれません。
そんなわけで中途半端で本当にすみませんふぁ、現状では頂いた不具合について対処ができませんでした。

お礼

Corutenさん色々とご対応いただき本当にありがとうございました！！感謝してます。マクロ初心者の私がここまでできただけで満足です。

今回のマクロを試してみたのが私のパソコンでバージョンはXPです。会社の端末は確かoffice2000だったと思いますので、会社で再度試してみます（＾＾）お忙しいのになんどもVBA書いていただいて本当にありがとうございました（__)

補足

今日会社のパソコンでもう一度試してみたら、イメージ通りのシートができ不具合も起きませんでした！！！素晴らしい出来栄えです！！！
Corutenさん本当にありがとうございました（＿＿）おかげ様で部内でも喜ばれました＾＾大変助かりました。

回答No.3

noname#196225

せっかくですので、改変後の全ソース載っけます。連投失礼。

Dim LName As String
Const Prefix As String = "" ' Page_A～Zの26シートが出力されます
Const SearchTarget As String = "部品名" '「部品名」と書いてあるセルの真下から空白セルまでを検索対象にします。
Const CopyColumnNumber As Integer = 0 ' 0は元のページの書式でコピーします。そのほかは相対値
Const CopyRowNumber As Integer = 0 ' 0は元のページの書式でコピーします。そのほかは相対値
Dim RAsc As Integer
Dim BaseCol As Integer
Dim BaseRow As Integer
Dim Sheet_ As Object
Dim Pgn(2 To 27) As Integer ' 整理番号

'ワークシートが非対応なら終了
Set Sheet_ = Worksheets.Item(1).Cells
If Sheet_.Find(SearchTarget) Is Nothing Then Exit Sub
BaseCol = Sheet_.Cells.Find(SearchTarget).Column
BaseRow = Sheet_.Cells.Find(SearchTarget).Row

'ワークシートが既に構成されていたら、初期処理を飛ばす
For i_ = 1 To Worksheets.Count
If Len(Worksheets.Item(i_).Name) = Len(Prefix) + 1 Then
LName = Left(LCase(Worksheets.Item(i_).Name), Len(Prefix))
RAsc = Asc(Right(UCase(Worksheets.Item(i_).Name), 1))
If LName = LCase(Prefix) And RAsc >= Asc("A") And RAsc <= Asc("Z") Then Exit For
End If
Next i_
If i_ = Worksheets.Count + 1 Then
Worksheets.Add Null, Worksheets.Item(1), 26
For i = 1 To 26
Worksheets.Item(i + 1).Name = Prefix + Chr(i + Asc("A") - 1)
Next i
Else
'過去の情報書き込み領域をクリア
For i = 1 To 26
Worksheets.Item(i + 1).Range(Cells(BaseRow + CopyRowNumber, BaseCol + CopyColumnNumber).Address, Cells(65536, 256).Address).Clear
Next i
End If
'書式をコピー
jmax = 0
Do While (Sheet_(BaseRow, BaseCol + jmax) <> "")
For i = 1 To 26
Sheet_(BaseRow, BaseCol + jmax).Copy Worksheets.Item(i + 1).Cells(BaseRow + CopyRowNumber, BaseCol + jmax + CopyColumnNumber)
Next i
jmax = jmax + 1
Loop
'各情報をセルに割り振り
i = 0
Do While (Sheet_(BaseRow + i, BaseCol) <> "")
LName = Sheet_.Cells(BaseRow + i, BaseCol)
RAsc = Asc(Left(UCase(LName), 1)) - Asc("A")
If RAsc >= 0 And RAsc <= 25 Then
Pgn(RAsc + 2) = Pgn(RAsc + 2) + 1
For j = 0 To jmax - 1
Sheet_(BaseRow + i, BaseCol + j).Copy Worksheets.Item(RAsc + 2).Cells(BaseRow + Pgn(RAsc + 2) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Next j
End If
i = i + 1
Loop
i = i - 1
For k = 1 To 26
For j = 0 To jmax
If Pgn(k + 1) > 0 Then
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Sheet_(BaseRow + i, BaseCol + j).Copy Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber) = ""
End If
Next j
Next k

補足

早速のご回答ありがとうございました。早速試してみました！
最初マクロを実行した時はちゃんとシートが出来、見出しも綺麗に元データと同じ書式になっていました。
ただデータを追加し、もう一度マクロを実行すると固まってしまいます。何か不具合がでてしまっているのでしょうか？

また、大変申し訳ないのですが、もし可能であればセルの大きさも元データと同じにしたいのですが。。色々していただいて申し訳ございませんが、ヘルプどうぞお願いいたします（＿＿）すみません。

回答No.2

noname#196225

すぐにできる内容だけお答えして、後は妥協かなと思いましたが、割と要望どおりできましたので載せますね。

１）Page_の部分はわざとそうしてしまいました。Page_の部分は自由に設定できまして、上部のConst Prefix As String = "Page_"を""にするだけでアルファベットのみのシートが作れます。
（その場合、申し訳ないですが、変更後は既に作ってしまったPage_A-Zの26枚は手動で削除してください。）
また余談ですが、その下の"部品名"を変更すれば見出しのターゲットも変更できます。

２）下記の部分を差し替えてください。
Worksheets.Item(i + 1).Cells(BaseRow + CopyRowNumber, BaseCol + jmax + CopyColumnNumber) = Sheet_(BaseRow, BaseCol + jmax)
から
Sheet_(BaseRow, BaseCol + jmax).Copy Worksheets.Item(i + 1).Cells(BaseRow + CopyRowNumber, BaseCol + jmax + CopyColumnNumber)

３）下記の部分を差し替えてください。
Worksheets.Item(RAsc + 2).Cells(BaseRow + Pgn(RAsc + 2) + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Sheet_(BaseRow + i, BaseCol + j)
から、
Sheet_(BaseRow + i, BaseCol + j).Copy Worksheets.Item(RAsc + 2).Cells(BaseRow + Pgn(RAsc + 2) + CopyRowNumber, BaseCol + j + CopyColumnNumber)

それから、コードの最後に
i = i - 1
For k = 1 To 26
For j = 0 To jmax
If Pgn(k + 1) > 0 Then
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Sheet_(BaseRow + i, BaseCol + j).Copy Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber)
Worksheets.Item(k + 1).Cells(BaseRow + Pgn(k + 1) + 1 + CopyRowNumber, BaseCol + j + CopyColumnNumber) = ""
End If
Next j
Next k
を付け加えてください。あまり格好の良いコードではないですし、結構穴が多いとは思いますが;^^

回答No.1

noname#196225

とりあえず即興で作ってみました。これをThisWorkbook内のWorkbook_Open()に貼り付けたらどうでしょう。

Dim LName As String
Const Prefix As String = "Page_" ' Page_A～Zの26シートが出力されます
Const SearchTarget As String = "部品名" '「部品名」と書いてあるセルの真下から空白セルまでを検索対象にします。
Const CopyColumnNumber As Integer = 0 ' 0は元のページの書式でコピーします。そのほかは相対値
Const CopyRowNumber As Integer = 0 ' 0は元のページの書式でコピーします。そのほかは相対値
Dim RAsc As Integer
Dim BaseCol As Integer
Dim BaseRow As Integer
Dim Sheet_ As Object
Dim Pgn(2 To 27) As Integer ' 整理番号

'ワークシートが非対応なら終了
Set Sheet_ = Worksheets.Item(1).Cells
If Sheet_.Find(SearchTarget) Is Nothing Then Exit Sub
BaseCol = Sheet_.Cells.Find(SearchTarget).Column
BaseRow = Sheet_.Cells.Find(SearchTarget).Row

'ワークシートが既に構成されていたら、初期処理を飛ばす
For i_ = 1 To Worksheets.Count
If Len(Worksheets.Item(i_).Name) = Len(Prefix) + 1 Then
LName = Left(LCase(Worksheets.Item(i_).Name), Len(Prefix))
RAsc = Asc(Right(UCase(Worksheets.Item(i_).Name), 1))
If LName = LCase(Prefix) And RAsc >= Asc("A") And RAsc <= Asc("Z") Then Exit For
End If
Next i_
If i_ = Worksheets.Count + 1 Then
Worksheets.Add Null, Worksheets.Item(1), 26
For i = 1 To 26
Worksheets.Item(i + 1).Name = Prefix + Chr(i + Asc("A") - 1)
Next i
Else
'過去の情報書き込み領域をクリア
For i = 1 To 26
Worksheets.Item(i + 1).Range(Cells(BaseRow + CopyRowNumber, BaseCol + CopyColumnNumber).Address, Cells(65536, 256).Address).Clear
Next i
End If
'書式をコピー
jmax = 0
Do While (Sheet_(BaseRow, BaseCol + jmax) <> "")
For i = 1 To 26
Worksheets.Item(i + 1).Cells(BaseRow + CopyRowNumber, BaseCol + jmax + CopyColumnNumber) = Sheet_(BaseRow, BaseCol + jmax)
Next i
jmax = jmax + 1
Loop
'各情報をセルに割り振り
i = 0
Do While (Sheet_(BaseRow + i, BaseCol) <> "")
LName = Sheet_.Cells(BaseRow + i, BaseCol)
RAsc = Asc(Left(UCase(LName), 1)) - Asc("A")
If RAsc >= 0 And RAsc <= 25 Then
Pgn(RAsc + 2) = Pgn(RAsc + 2) + 1
For j = 0 To jmax - 1
Worksheets.Item(RAsc + 2).Cells(BaseRow + Pgn(RAsc + 2) + CopyRowNumber, BaseCol + j + CopyColumnNumber) = Sheet_(BaseRow + i, BaseCol + j)
Next j
End If
i = i + 1
Loop

補足

早速のご回答ありがとうございます！！完璧にシートに分かれていました！
ただもう少しお願いがございまして、可能であれば、シート名がpage_XXとなっていますが、アルファベッドのみのシート名にすることは可能でしょうか？
また元データのみだし部分（部品名、詳細、金額・・・）がセルが青、太文字、でかかれおり、アルファベッドのシートにも同じ書式設定で反映させたいのですが。。あとデータ全体的に格子もついています。
（見出し部分）
部品名 詳細 金額 社名 その他

このようなものは無理でしょうか？
もし難しいようであれば、部品の隣のセルにLEFT関数で、アルファベット頭文字を反映させて、それをシート名で使用するようなマクロでも結構なのですが。
マクロ初心者で申し訳ございませんが、どうぞよろしくお願いいたします。お忙しいところすみません。