excelで罫線を引くマクロを教えてください

エクセルで、以下のような表があったとします

商品コード　　商品名　　商品の特徴
０００１　　　商品１　　　商品１の特徴１
　　　　　　　　　　　　　　　商品１の特徴２
０００２　　　商品２　　　商品２の特徴１
　　　　　　　　　　　　　　　商品２の特徴２
　　　　　　　　　　　　　　　商品２の特徴３
　　　　　　・
　　　　　　・
　　　　　　・

この場合に、一つの商品の情報を実線で囲み、その中を
１行づつ横に点線を引くという作業がしたいのです。

ただ、その時によって商品の数が変わるため、
(1)一つの商品の範囲を認識して罫線を引く
(2)その時によって数が変わる商品それぞれに(1)の操作をする
この２点をクリアしたマクロが作りたいのです

皆様のお知恵を貸してください。

ちなみにexcel2003です。

No.1 回答者： turuzou 回答日時： 2009/05/25 23:58

サンプルです、修正は、ご自分で、お願いします。

Sub keisen()
　Dim x, y
　For x = Cells(65536, 3).End(xlUp).Row To 2 Step -1
　　y = IIf(Cells(x, 1).Value = "", Cells(x, 1).End(xlUp).Row, x)
　　With Range(Cells(y, 1), Cells(x, 3))
　　　.Borders(xlEdgeLeft).LineStyle = xlContinuous
　　　.Borders(xlEdgeTop).LineStyle = xlContinuous
　　　.Borders(xlEdgeBottom).LineStyle = xlContinuous
　　　.Borders(xlEdgeRight).LineStyle = xlContinuous
　　　If x <> y Then .Borders(xlInsideHorizontal).LineStyle = xlDot
　　End With
　　x = y
　　If x - 1 <= 2 Then Exit Sub
　Next x
End Sub

この回答へのお礼

ありがとうございます！！

列が、例では３列までですが、７列まである場合は、

１）　For x = Cells(65536, 7).End(xlUp).Row To 2 Step -1
２）　With Range(Cells(y, 1), Cells(x, 7))

に変えるだけで大丈夫でしょうか？

これだけでも充分効率化は図れるのですが、作っていただいた
ものですと、横線がすべて点線になっており、商品が変わる毎に
実線で区切りたい場合は、どうすればよろしいのでしょうか？

重ねてお願いいたします。

お礼日時：2009/05/26 11:22

No.2 回答者： turuzou 回答日時： 2009/05/26 00:21

No.1です、訂正です。

If x - 1 <= 2 Then Exit Sub
↓
If x <= 2 Then Exit Sub
失礼しました。

No.3 回答者： imogasi 回答日時： 2009/05/26 11:51

こんなの簡単で、丸投げすることも無いでしょう。

（１）まづマクロの記録を取り（罫線を引く位置は置いといて）
罫線、点線を引くなどのコードがどうなるか知る。
上罫線だけを引く場合はどういうコードになるか。
それと多数列に罫線の引き方のコード。
（２）実線を引く場所の特徴を考える。これは質問者が一番良く事情を知っているはず。
例　各行で商品名の列が空白でなかったら、上罫線を実線で引く
（３）点線を引くべき行の特徴を考える。
例　商品列が空白なら、上罫線を点線で引く。
＝＝＝
以上ぐらい考えて、何か疑問があれば質問するようにしないと。
頼りすぎ。　Ｇｏｏｇｌｅででも罫線を引く、点線を引く　ＶＢＡで照会したら。
内容も難しい点はないと思う。

No.4 回答者： turuzou 回答日時： 2009/05/26 12:51

No.1です。

＞サンプルです、修正は、ご自分で、お願いします。

＞・・・に変えるだけで大丈夫でしょうか？
最初から実際の範囲を提示するべきですし、確認してから質問してください。

>・・・横線がすべて点線に
A列に例題の様にコード番号が入力されていれば、こちらでは実線が引かれています。

追記
Dim x, y　の下へ
Application.ScreenUpdating = False　

If x <= 2 Then Exit Sub　を削除して
Next x　の下へ
Application.ScreenUpdating = True
としてみても

この回答へのお礼

＞最初から実際の範囲を提示するべきですし・・・
申し訳ございません。

実際は、
商品コード/発注部署/発注日/納品日/商品名/特徴の分類/特徴の内容
となっており、商品コードが０００１ではなく、５桁で51237とか
85068みたいな数字なんです。

空白になり得るのは
特徴の分類/特徴の内容以外の５列です。

No3の方も仰る通り、色々調べてやってはみたのですが、なぜか
実線が引かれず、うまくいかない原因を見つけられません。

お力をお貸し頂ければ幸いです。

お礼日時：2009/05/26 23:10

No.5 回答者： i_september 回答日時： 2009/05/27 01:02

こんにちは。

ちょっと式が複雑になりますが、条件付き書式で希望の動きになるかと思います。

A1:商品コード
B1:商品名
C1:商品情報
として、2行目からデータを入力すると仮定します。

A列とB列の2行目には
(1)下部実線書式：数式が
=OR((AND(C2<>"",A3="",C3="")),(AND(C2<>"",A2="",C3<>"",A3<>"")),(AND(C2<>"",A2<>"",C3<>"",A3<>"")))
(2)下部点線書式：
=AND(C2<>"",A3="",C3<>"")
C列2行目には
(1)下部実線書式/右部実線書式：数式が
=OR((AND(C2<>"",A3="",C3="")),(AND(C2<>"",A2="",C3<>"",A3<>"")),(AND(C2<>"",A2<>"",C3<>"",A3<>"")))
(2)下部点線書式/右部実線書式：数式が
=AND(C2<>"",A3="",C3<>"")
と入れて、下の行へ書式の複写をして下さい。
するとほぼ同様の動きになると思います。後は、数式・書式の調整を行ってください。

私も、3行ごとに罫線を引いて入力するなどで使っています。

No.6 回答者： turuzou 回答日時： 2009/05/27 01:09

お疲れ様です。

多分A列は空白に見えていて、数式で空を表示していたり、スペースがあったりしていませんか(本当の空白セルではない)？

提示したマクロは、サンプル画像での、A11　がアクティブセルの時、Ctrl+↑ 押下で、A10(0003)がアクティブにならないと、実線が引かれませんので、確認して下さい。
例えばA列の最下行のセルを選択して、Ctrl+↑ 押下で A1 セルが選択されると、現在のマクロでは正しく動作しません。

A列に数式があり、数式を削除してよいならば、A列の範囲を選択してコピー→形式を選択して貼り付け の 値 で、数式を削除してみてください。

A列の最下行から、Ctrl+↑を繰り返し押下して、コード番号を順々に選択できるようになれば、現在のマクロで実線が引かれます。

又は、
＞空白になり得るのは　特徴の分類/特徴の内容以外の５列
上記の列で、本当の空白セルがある列があるのならば、その列を対象に商品コード別の範囲の上限を捜すことも出来ます。(補助列を作っても良いと思います)

Sheetの変更が出来ないのならば、No.3さんでも書かれているように、1行ずつ、A列を基準に、罫線種を選択しながら、上罫線を引くマクロになると思います。

No.7 回答者： turuzou 回答日時： 2009/05/27 18:13

No6　の追記です。

A列の空白セルを空白にさせるには、色々ありますが、
(数式などを削除しても、Ctrl+↑で、コード番号を選択できない場合)
A列を選択 → データ → 区切り位置 → 完了　で、空白セルになると思います。

又は、A1を選択 → フィルタ → オートフィルタ → フィルタの 空白セル を抽出 → 表示されたA列のセルを選択 → Delete　で、空白セルになると思います。

ご自分で作成(修正)された、マクロを提示してみて、A列等の表示が直接入力なのか、数式等で、表示させているのかも、お教え下さい。

No.8 回答者： xls88 回答日時： 2009/05/27 19:05

商品コードの列で、コード入力セル以外は、間違いなく空白セルである

ということなら、turuzouさんのコードで希望通りの動作をします。
商品コード列の最上行セルで、Ctrl＋↓ とキー操作してみてください。
最終行までカーソルが移動するなら、空白セルはないので、すべて破線になります。

数値かどうか判定すればどうでしょうか。
試しに組んでみました。
Sub test1()
　　Dim rng As Range
　　Dim r As Range
　　
　　Set rng = Range("A1", "A" & Cells(Rows.Count, "C").End(xlUp).Row)
　　rng.Resize(, 3).BorderAround LineStyle:=xlContinuous, Weight:=xlThin
　　Set rng = rng.Offset(1).Resize(rng.Count - 1)
　　For Each r In rng
　　　　With r.Resize(, 3).Borders(xlEdgeTop)
　　　　　　If IsNumeric(r.Value) Then
　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　.Weight = xlThin
　　　　　　Else
　　　　　　　　.LineStyle = xlDash
　　　　　　　　.Weight = xlThin
　　　　　　End If
　　　　End With
　　Next
End Sub

＞No3の方も仰る通り、色々調べてやってはみたのですが、なぜか
＞実線が引かれず、うまくいかない原因を見つけられません。
抽象的なことでなく、ご自分でやったこと、書いたコードを提示し、
間違いを指摘してもらうようにすればどうでしょうか。
希望通りの動作をするコードの提供を待っているより、確実に実力UPになると思います。