Excelで楽に表を作る方法を教えてください

月に一度下記のような形式で、データが送られてきます。

写真では14行までですが、大体月に2000～3000行程の膨大なデータが送られてきます。

これを現在、手入力にて、写真のような表を作成しています。

1つのデータにつき2行を使用して表を作成しています。
点検期間と言うのは、頻度1か頻度2に入ってる値を30で割って、出た数字をヶ月として表記しております。

現在この表を作るだけで数日を要しており、毎月作成するので手が回らない状態です。

この表をどうにかして楽に、もしくは早く作成する方法は無いでしょうか？
お力をお貸し下さい。

No.4 回答者： tsubuyuki 回答日時： 2013/04/30 02:18

元のリストを、別なシートに作り変える感じです。

実際のシート名に置き換えてお試しくださいませ。
（転記先シートは用意されている前提です。）

Sub sample()
Dim SH1 As Worksheet, SH2 As Worksheet
Dim TRow As Long

　　　　Set SH1 = Sheets("Sheet1"): Set SH2 = Sheets("Sheet2")

　　　　With SH2
　　　　　　　　.Cells.Delete
　　　　　　　　.Cells(1, 1) = "整備リスト"
　　　　　　　　.Cells(2, 1) = Format(Now, "yyyy年mm月作成")
　　　　　　　　.Cells(3, 1) = "番号"
　　　　　　　　.Cells(3, 2) = "部位"
　　　　　　　　.Cells(3, 3) = "名称"
　　　　　　　　.Cells(4, 3) = "付帯事項"
　　　　　　　　.Cells(3, 4) = "点検内容"
　　　　　　　　.Cells(3, 5) = "点検期間"
　　　　　　　　With .Range("A3:A4")
　　　　　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　.MergeCells = True
　　　　　　　　End With
　　　　　　　　With .Range("B3:B4")
　　　　　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　.MergeCells = True
　　　　　　　　End With
　　　　　　　　With .Range("D3:D4")
　　　　　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　.MergeCells = True
　　　　　　　　End With
　　　　　　　　With .Range("E3:E4")
　　　　　　　　　　　　.HorizontalAlignment = xlCenter
　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　.MergeCells = True
　　　　　　　　End With

　　　　　　　　TRow = 5
　　　　　　　　For i = 2 To SH1.Cells(SH1.Rows.Count, 1).End(xlUp).Row
　　　　　　　　　　　　.Cells(TRow, 1) = SH1.Cells(i, 1)
　　　　　　　　　　　　.Cells(TRow, 2) = SH1.Cells(i, 2)
　　　　　　　　　　　　.Cells(TRow, 3) = SH1.Cells(i, 3)
　　　　　　　　　　　　.Cells(TRow + 1, 3) = SH1.Cells(i, 4)
　　　　　　　　　　　　.Cells(TRow, 4) = SH1.Cells(i, 5)
　　　　　　　　　　　　.Cells(TRow + 1, 4) = SH1.Cells(i, 6)
　　　　　　　　　　　　If SH1.Cells(i, 7) > 0 Then
　　　　　　　　　　　　　　　　.Cells(TRow, 5) = SH1.Cells(i, 7) / 30
　　　　　　　　　　　　ElseIf SH1.Cells(i, 8) > 0 Then
　　　　　　　　　　　　　　　　.Cells(TRow, 5) = SH1.Cells(i, 8) / 30
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　.Cells(TRow, 5) = "対象外"
　　　　　　　　　　　　End If
　　　　　　　　　　　　With .Range(.Cells(TRow, 1), .Cells(TRow + 1, 1))
　　　　　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　　　　　.MergeCells = True
　　　　　　　　　　　　End With
　　　　　　　　　　　　With .Range(.Cells(TRow, 2), .Cells(TRow + 1, 2))
　　　　　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　　　　　.MergeCells = True
　　　　　　　　　　　　End With
　　　　　　　　　　　　With .Range(.Cells(TRow, 5), .Cells(TRow + 1, 5))
　　　　　　　　　　　　　　　　.VerticalAlignment = xlCenter
　　　　　　　　　　　　　　　　.MergeCells = True
　　　　　　　　　　　　　　　　.NumberFormatLocal = "#ヶ月"
　　　　　　　　　　　　End With
　　　　　　　　　　　　TRow = TRow + 2
　　　　　　　　Next i
　　　　End With
End Sub



一セルずつ処理していくように書いてあるのでかなりくどいです（笑）。
実用的とも言いづらいので、とりあえずは参考までに。

No.3 回答者： tom04 回答日時： 2013/04/29 22:25

No.2です！

たびたびごめんなさい。
質問にちゃんと書いてありましたね！

＞点検期間と言うのは、頻度1か頻度2に入ってる値を30で割って、出た数字をヶ月として表記しております。

の部分を見逃していました。

前回のコードは無視して↓のコードに変更してみてくさい。

Sub 並び替え() 'この行から
Dim i As Long
i = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Cells(1, 1).Resize(i, 1)
.Formula = "=row()"
.Value = .Value
.Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
Cells(1, 1).CurrentRegion.Sort key1:=Cells(1, 1), order1:=xlAscending, Header:=xlNo
Range("A:A").Delete

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 2
Application.DisplayAlerts = False
Cells(i, 4).Cut Cells(i + 1, 3)
Cells(i, 5).Cut Cells(i, 4)
Cells(i, 6).Cut Cells(i + 1, 4)
Cells(i, 5) = WorksheetFunction.Max(Range(Cells(i, 7), Cells(i, 8))) / 30 & "ヶ月"
Cells(i, 1).Resize(2, 1).Merge
Cells(i, 2).Resize(2, 1).Merge
Cells(i, 5).Resize(2, 1).Merge
Next i
With Cells(1, 4).Resize(2, 1)
.Merge
.Value = "点検内容"
End With
With Cells(1, 5).Resize(2, 1)
.Merge
.Value = "点検期間"
End With
Application.DisplayAlerts = True
Range("F:H").Delete
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

※　ご希望通りの動きになれば良いのですが・・・
何度も失礼しました。m(_ _)m

No.2 回答者： tom04 回答日時： 2013/04/29 21:54

こんばんは！

VBAになってしまいますが、一例です。

画像では元データのG列以降のデータをどこに表示させているのか判らないので
F列までのデータを画像の下側の配置になるようにやってみました。

画面左下の操作したいSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub 並び替え() 'この行から
Dim i As Long
i = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
Range("A:A").Insert
With Cells(1, 1).Resize(i, 1)
.Formula = "=row()"
.Value = .Value
.Copy Cells(Rows.Count, 1).End(xlUp).Offset(1)
End With
Cells(1, 1).CurrentRegion.Sort key1:=Cells(1, 1), order1:=xlAscending, Header:=xlNo
Range("A:A").Delete

For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 2
Application.DisplayAlerts = False
Cells(i, 4).Cut Cells(i + 1, 3)
Cells(i, 5).Cut Cells(i, 4)
Cells(i, 6).Cut Cells(i + 1, 4)
Cells(i, 1).Resize(2, 1).Merge
Cells(i, 2).Resize(2, 1).Merge
Cells(i, 5).Resize(2, 1).Merge
Next i
With Cells(1, 4).Resize(2, 1)
.Merge
.Value = "点検内容"
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub 'この行まで

※　一旦マクロを実行すると元に戻せませんので
別Sheetでマクロをためしてみてください。m(_ _)m

No.1 回答者： bin-chan 回答日時： 2013/04/29 20:49

> 1つのデータにつき2行を使用して表を作成しています。

まず、編集用シートを作成して、１行でデータを作成する。
左半分が１行目、右半分が２行目に相当するイメージ。
値の検証まですませんてから、編集用シートを参照する「結果シート」を作成。
（あるいはテンプレート化）

結果シートは２行１セットの書式があれば十分。
うまく参照できたら、必要な行数を下方向にコピーして
送付件数×２行あることを確認。

全体をコピーして、「形式を選択して貼り付け-値」で参照を切り離す。

でしょうか。