エクセルで複数のシートに罫線を引くマクロを教えてください。

エクセルで複数のシートに罫線を引くマクロを教えてください。

エクセルの表を担当者名でシート分割後、空白セル以外に罫線を引きたいのですが
複数シートに罫線を引くマクロを教えてください。
いくつか参考にさせていただき現状以下の様になっています。

元データというシートにAからGまで項目があります

PJNo.PJ名棟No.棟名取引先名　書類　　担当者
1111PJ１10棟１取引先１　1 東京
1112PJ２11棟２取引先２　 2 大阪
1113PJ３12棟３取引先３　3 名古屋

Sub 担当別シート作成()
Application.ScreenUpdating = False
For i# = 2 To Worksheets("元データ").Cells(2, 2).End(xlDown).Row
j# = 1
'検索中の人のシートが既にできているかを判断する。
For Each sheet_name In Worksheets
If sheet_name.Name = Worksheets("元データ").Cells(i, 7).Value Then
j = 7
Exit For
End If
Next
'検索中の人のシートがない場合、新規に作成する。
If j = 1 Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = Worksheets("元データ").Cells(i, 7).Value
For j = 1 To 7
Worksheets(Worksheets.Count).Cells(1, j).Value = Worksheets("元データ").Cells(1, j).Value
Next j
End If
'データのコピー
For j = 7 To 1 Step -1
Worksheets(Worksheets("元データ").Cells(i, 7).Value). _
Cells(Worksheets(Worksheets("元データ").Cells(i, 7).Value). _
Cells(65535, 1).End(xlUp).Row + 1, j).Value = Worksheets("元データ").Cells(i, j).Value
Next j
Next i
'それぞれのシートの列幅を最適化します。
For Each sheet_name In Worksheets
sheet_name.Columns("A:G").AutoFit
Next
'----
Dim c As Range
Range("A1").Select
Set c = Selection.SpecialCells(xlCellTypeLastCell)
Range(Cells(1, "A"), c).Select
（省略）以下罫線を引くマクロ
End Sub

No.6 ベストアンサー 回答者： hige_082 回答日時： 2010/02/17 12:42

＞罫線は上手く引けましたが、項目の行も1シート作成され、他シートには項目行が入っていません。

ありえません
質問を元にサンプルを作成し、テストしましたが補足のようにはなりません
あるとすれば、質問の表の構成と実際の表の構成が違うのではと思います
こちらでテストした表は
＞元データというシートにAからGまで項目があります
A列からG列までが項目で
＞For j = 1 To 7
＞Worksheets(Worksheets.Count).Cells(1, j).Value = Worksheets("元データ").Cells(1, j).Value
＞Next j
ここで項目のある行を1行目と判断できる
＞For i# = 2 To Worksheets("元データ").Cells(2, 2).End(xlDown).Row
他のコードから、ここでデータ行の始まりが
2行目からとなっている

質問には明確に書かれていないのでコードから判断しましたが、違うのでしょうか？
上の条件でテストした限りでは、不具合はありませんが？
どのような表で試されたのでしょうか？

補足をお願いします

この回答へのお礼

失礼しました。2回目の修正の際に2行の修正を3行に貼り付けていました。
度々お手数お掛けしました。
ありがとうございました。

お礼日時：2010/02/20 19:44

No.5 回答者： hige_082 回答日時： 2010/02/14 23:15

度々、申し訳ありません

単純な、私のミスです
下記の修正お願いします

＞'検索中の人のシートがない場合、新規に作成する。
＞If sheet_name Is Nothing Then
＞Set sheet_name = Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = .Cells(i, 7).Value
　　　　↓　↓
'検索中の人のシートがない場合、新規に作成する。
If sheet_name Is Nothing Then
Set sheet_name = Worksheets.Add(After:=Worksheets(Worksheets.Count))
sheet_name.Name = .Cells(i, 7).Value

お手数おかけします

この回答への補足

罫線は上手く引けましたが、項目の行も1シート作成され、他シートには項目行が入っていません。
引き続き宜しくお願いします。

補足日時：2010/02/16 22:43

No.4 回答者： hige_082 回答日時： 2010/02/14 19:04

申し訳ありません

下記の修正をお願いします
＞　　：
＞c.Borders(xlEdgeRight).Weight = xlThin
＞Next
＞Next i
＞　　：
を
　　：
c.Borders(xlEdgeRight).Weight = xlThin
End If
Next
Next i
　　：
の様に「End If」が抜けていました

お手数おかけします

この回答への補足

エラー424
オブジェクトが必要です
というエラーが出てしまいました。
お時間あれば再度お願いします。

補足日時：2010/02/14 21:03

No.3 回答者： hige_082 回答日時： 2010/02/14 09:12

こんな感じで？

Sub 担当別シート作成()
Dim i
Dim j
Dim sheet_name As Worksheet
Dim c As Range

Application.ScreenUpdating = False
With Worksheets("元データ")
For i = 2 To .Cells(2, 2).End(xlDown).Row

'検索中の人のシートが既にできているかを判断する。
For Each sheet_name In Worksheets
If sheet_name.Name = .Cells(i, 7).Value Then Exit For
Next

'検索中の人のシートがない場合、新規に作成する。
If sheet_name Is Nothing Then
Set sheet_name = Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = .Cells(i, 7).Value
.Cells(1, 1).Resize(1, 7).Copy sheet_name.Cells(1, 1)
End If

'データのコピー
.Cells(i, 1).Resize(1, 7).Copy sheet_name.Cells(65535, 1).End(xlUp).Offset(1)

'それぞれのシートの列幅を最適化します。
sheet_name.Columns("A:G").AutoFit

'以下罫線を引くマクロ
For Each c In sheet_name.Range("A1", sheet_name.Cells.SpecialCells(xlCellTypeLastCell))
If c.Value <> "" Then
c.Borders(xlEdgeLeft).Weight = xlThin
c.Borders(xlEdgeTop).Weight = xlThin
c.Borders(xlEdgeBottom).Weight = xlThin
c.Borders(xlEdgeRight).Weight = xlThin
Next
Next i
End With
Application.ScreenUpdating = True
End Sub

参考まで

この回答への補足

とてもシンプルになるんですね。
初心者ですのでとても参考になります。
ありがとうございます。

早速試してみたのですが
'以下罫線を引くマクロの
Nextでエラーがでて止まってしまいました。
素人なりに色々とやってみましたが自力では無理なようで
再度助けていただけたらと思います。
宜しくお願いします。

補足日時：2010/02/14 10:52

No.2 回答者： tom04 回答日時： 2010/02/13 23:33

No．1です！

たびたびごめんなさい。

投稿した後もう一度質問文を読み返してみると
>エクセルで複数のシートに罫線を・・・

とありましたので、再び顔を出してしまいました。
そして、前回の方法も少し改善してみました。

全てのSheetのA～G列という前提です。

画面左下のSheet1を開いた状態でShiftキーを押しながら最後のSheetタブをクリックします。
これで全てのSheetが作業グループ化されましたので
A～G列全てを範囲指定　→　条件付書式　→　数式が　→　数式欄に
=A1<>""　として　好みの罫線を選択　→　OK
これで完了です。
最後にSheetタブ上で右クリックし、作業グループを解除してください。

前回の方法では数式等が入っていて、空白であっても罫線が引かれたと思いますが、
今回の方法だと数式等が入力されていても問題ないと思います。

どうも何度も失礼しました。m(__)m

この回答へのお礼

とても丁寧に説明していただきありがとうございます。
やってみましたが先に提案していただいた０と等しくない方法で上手くいきました。
=A1<>""の方はA1から書式のコピーが必要なようで少し手間がかかりました。
マクロが使えない場合はこちらで作業させていただきます。
ありがとうございました。

お礼日時：2010/02/14 10:35

No.1 回答者： tom04 回答日時： 2010/02/13 22:47

こんばんは！

VBAでないので参考にならなかったら無視してください。

単純に条件付書式を利用してはダメですか？

当方使用のExcel2003の場合ですが、
A～G列全てを範囲指定　→　書式　→　条件付書式　→　「セルの値が」　→　「次の値に等しくない」　→　「0」を入力　→　書式　→　罫線タブで好みの罫線を選択　→　OK

これでA～G列の空白以外のセルに罫線が表示できるはずです。
尚、数値が入力され「0」の場合は条件に当てはまりませんので気をつけてください。

以上、長々と書きましたが
的外れなら読み流してくださいね。m(__)m