エクセル2010を使用 マクロで別シートにコピーを

質問

ご覧いただき有難うございます。

エクセル2010を使用して事務の仕事をしています。
顧客が500件弱あります。新たに取引をしてくださる業者様として取引業者様が増えたり、何年も取引がなく取引業者様として登録を削除する業者様があり、1年に何回も増減を繰り返しています。

1シート目にマスターデータとして顧客業者様名や顧客番号やその他リストが一部色付きで4行目～500行近くまで順にデータ化しております（画像の左側をご覧ください）。

それを、別シートの表形式にセルの色や文字種含めてコピー＆ペーストしたいと思っております（画像の右側をご覧ください）。

マクロ初心者のため、どのようなマクロを作れば増減にも対応し色や文字種含めてコピー＆ペーストできるのかわからず困っております。
詳しい方、どうぞご教授いただけないでしょうか？
よろしくお願いいたします。

回答No.3

nishi6 · ベストアンサー

データのコピーは一旦Sheet2に全データーを貼り付け、カットアンドペーストをしました。
添付図を見ると、表側（ふりがな）が特別に編集されているのでそのようにしてみました。
最後に、表題をコピーし、列幅を自動調整しています。なお、メニューデータに空白行は無いとしています。

メニューの左上位置、コピー先の左上位置、シート名、表題の列数、あいうえお順の行数、は実際のデータ内容に設定してください。

標準モジュールに貼り付けてください。Sheet1、Sheet2のいずれで実行しても構いません。当方Excel2010です。

Sub ordAIUEO()
　　Dim ws1 As Worksheet, ws2 As Worksheet '// Sheet1,2
　　Dim rgSTop As Range　　 '// メニューの左上位置
　　Dim rgDTop As Range　　 '// コピー先の左上位置
　　Dim rgHdai As Range　　 '// 表題
　　Dim bunkatsu As Integer '// メニューの分割数
　　Dim numMenu As Integer　　'// メニューの行数

　　Const h_Col = 5　　　　 '// 表題の列数
　　Const r_Row = 29　　　　 '// あいうえお順の行数

　　Set ws1 = Worksheets("Sheet1")
　　Set ws2 = Worksheets("Sheet2")
　　Set rgSTop = ws1.Range("B3")
　　Set rgDTop = ws2.Range("B3")
　　Set rgHdai = Range(rgSTop, rgSTop.Offset(0, h_Col - 1))

　　Dim Furigana As String　　　　　　 '// ふりがな
　　Dim rw As Integer, col As Integer '// 行、列カウンタ

　　ws2.Activate: rgDTop.CurrentRegion.Select: Selection.Clear
　　ws1.Activate: rgSTop.CurrentRegion.Select '// メニューデータ
　　Selection.Copy rgDTop
　　ws2.Activate: rgDTop.CurrentRegion.Select '// コピーデータ
　　Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select

　　With Selection
　　　　numMenu = .Rows.Count
　　　　bunkatsu = Int((numMenu - 1) / r_Row) + 1

　　　　Furigana = .Cells(1, 1)
　　　　For rw = 1 To numMenu '// 表側を整える
　　　　　　If .Cells(rw, 1) <> "" Then
　　　　　　　　Furigana = .Cells(rw, 1).Value
　　　　　　End If
　　　　　　If (rw - 1) Mod r_Row = 0 And .Cells(rw, 1) = "" Then
　　　　　　　　.Cells(rw, 1) = Furigana
　　　　　　End If
　　　　Next
　　End With

　　With rgDTop '// コピーする
　　　　For col = 1 To bunkatsu - 1
　　　　　　Range(.Offset(r_Row + 1, h_Col * (col - 1)), _
　　　　　　　　 .Offset(numMenu, h_Col * col)).Cut .Offset(1, h_Col * col)
　　　　Next
　　End With

　　For col = 2 To bunkatsu　　'// 表題を整える
　　　　rgHdai.Copy rgDTop.Offset(0, h_Col * (col - 1))
　　Next

　　'// 列幅の自動調整
　　Range(rgDTop, rgDTop.Offset(0, bunkatsu * h_Col - 0)).EntireColumn.AutoFit
　　rgDTop.Select
End Sub

お礼

改めてのお礼が遅くなりまして申し訳ありませんでした。
こちらの意図を汲んでいただき、また更にはマクロまで組んでいただき感謝しております。
自分のリストでマクロを試してみまして、きちんとコピー＆ペーストできていることに
感激いたしました！
あとはプリントの際にA4用紙2～3枚に収まるように行高さや列幅等がうまく調整できない
ものか頑張ってみたいと思います。
感謝の意を込めてベストアンサーにさせていただきます。
もしまた何かありましたらどうぞよろしくお願いいたします。

回答No.2

Mathmi

・500行くらいあるデータを、35行分ずつ折り返して、横に並べていきたい。
・各データの1列目はあ、い、う……の見出しであり、折り返した最初の行には追加したい。
　という事だと理解しました。
　違いあれば連絡下さい（背景色、文字色、フォント以外はコピーしたくない等）。

＞色や文字種含めてコピー＆ペースト
基本的に、コピー&ペーストしたら、自動的に背景色、文字色やフォントもコピーされます。

以下のコードでは、ペーストしたい35行分を確定し、ペースト先にコピー、を繰り返しています。
見出しの追加はまだ実装していません。
他にも、コピーする列数が5列固定だったり、リストに空白行がない前提だったりと、まだまだ改善の余地があるコードではありますが。

Sub test()
Dim cnt As Integer
Dim CopySheet As Worksheet
Dim PasteSheet As Worksheet
Dim CopyBaseCell As Range
Dim PasteBaseCell As Range
Dim CopyRange As Range 'コピー元のセル範囲
Dim PasteRange As Range 'ペースト先のセル範囲
Dim WrapRow As Integer
Dim LastRow As Integer 'コピー元の最終行の番号

Set CopySheet = Worksheets("Sheet1") 'コピー元シート
Set PasteSheet = Worksheets("Sheet2") 'ペースト先シート
Set CopyBaseCell = CopySheet.Range("B4") 'コピー範囲の左上セル
Set PasteBaseCell = PasteSheet.Range("C5") 'ペースト範囲の左上セル
WrapRow = 35 'ペースト先で折り返す行数

LastRow = CopyBaseCell.Offset(0, 1).End(xlDown).Row
Set CopyRange = CopyBaseCell.Resize(LastRow - CopyBaseCell.Row + 1, 5)

cnt = 1
Do Until CopyRange.Rows.Count < (cnt - 1) * WrapRow + 1
CopyRange((cnt - 1) * WrapRow + 1, 1).Resize(WrapRow, 5).Copy PasteBaseCell.Offset(0, (cnt - 1) * 5)
cnt = cnt + 1
Loop
End Sub

お礼

改めてのお礼が遅くまりまして申し訳ありませんでした。
こちらの意図を汲んだうえでマクロを組んでいただき有難うございました。
自分なりにも試してみましたが、初心者の自分ではまだ少し難しかったので
もう少し勉強してみてこちらのマクロを搭載してどうなるかを改めて確かめ
てみたいと思います。
お忙しいなかをマクロを組んでいただき有難うございました。

回答No.1

kkkkkm

マクロの記録で手作業でソート(並び替え)してからコピペの手順を記録したらそのまま使えるようにも思えます…。

お礼

改めてのお礼が遅くなりまして申し訳ありませんでした。
初心者の自分のスキルでマクロの記録からコピペ手順を記録し、かつデータが変わったときに
プリントをすることを考え、毎回データを消去してからはじめるようなマクロも入れてみました。マクロをボタンに登録したりできないものか、いま試してみています。
初心者が試してみることができる意見をいただき有難うございました。
いま頑張れば、後々の作業が楽になると思って頑張ってみます。