19-02_keisen

タイトル欄のアドレスは、エクセルファンクラブの該当する頁へのリンク先です。
詳しい事は、こちらのお願いをご覧になってください。

21	空白行を含む、印刷範囲の最終ページ最終行まで罫線とひくには？ http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200206/02060118.txt 　「ページの下に罫線を引くには」　【編集ラウンジ】
最終行より下の、そのページの全セルに罫線をひきます。最終ページの行数は、１ページ目の行数と同じとしています。横の改ページには対応していません。 Sub miko_test() 　Dim Lastpage As Long, Lastrow As Long, LastR As Long, LastC As Integer 　On Error GoTo err1 　'縦方向最終改ページ数取得　Lastpage = ActiveSheet.HPageBreaks.Count 　'入力済み最終行、最終列取得　LastR = Cells(Application.Rows.Count, 1).End(xlUp).Row 　With ActiveSheet.UsedRange 　　LastR = .Row + .Rows.Count - 1 　　LastC = .Column + .Columns.Count - 1 　End With 　'最終ページの最下行取得　If Lastpage = 0 Then 　　Lastrow = Application.InputBox(Prompt:="１ページで納まります。最終行を入力してください。" & Chr(10) & _ 　　"入力済み最終行は " & LastR & " 行目なので、それ以上の数値です", Default:=LastR + 0, Type:=1) 　Else 　　’線を引く最終行は、そのページの三頭行＋１ページ目の行数－２　　Lastrow = ActiveSheet.HPageBreaks(Lastpage).Location.Row + ActiveSheet.HPageBreaks(1).Location.Row - 2 　End If 　'入力済み行の下から、最終ページ最下行の1～最終列に罫線を引く　With Range(Cells(LastR + 1, 1), Cells(Lastrow, LastC)) 　　.Borders(xlEdgeLeft).LineStyle = xlContinuous 　　.Borders(xlEdgeTop).LineStyle = xlContinuous 　　.Borders(xlEdgeBottom).LineStyle = xlContinuous 　　.Borders(xlEdgeRight).LineStyle = xlContinuous 　　.Borders(xlInsideVertical).LineStyle = xlContinuous 　　.Borders(xlInsideHorizontal).LineStyle = xlContinuous 　End With err1: End Sub 　　この使い方は、マクロの使い方(１)標準モジュールにあります。　　罫線の種類については、罫線の定数をご覧ください
22	改ページごとに、各ページの外枠に罫線を引くには？ http://cgi.fuji.ne.jp/~fj2094/cgi-bin1/wwwlng.cgi?print+200206/02060159.txt 　「長い表の外枠を改ページした場所で常に太線にするには？」　【編集ラウンジ】
各ページの外枠に罫線をひきます。 Sub 改ページごとに外枠線() 　Dim Lastpage As Long, Lastpage2 As Long 　Dim LastR As Long, LastC As Integer, i As Integer, j As Integer 　Dim Nrow As Long, NLrow As Long, Ncol As Integer, NLcol As Integer 　Application.ScreenUpdating = False '画面の動きを固定　'正しく改ページ位置を取得する為、一旦改ページプレビューにする　ActiveWindow.View = xlPageBreakPreview 　'縦方向最終改ページ数取得　Lastpage = ActiveSheet.HPageBreaks.Count 　'横方向最終改ページ数取得　Lastpage2 = ActiveSheet.VPageBreaks.Count 　'入力済み最終行、最終列取得　With ActiveSheet.UsedRange 　　LastR = .Row + .Rows.Count - 1 　　LastC = .Column + .Columns.Count - 1 　End With 　Ncol = 1 　'横方向改ページ分繰り返し　For j = 1 To Lastpage2 + 1 　　If j = Lastpage2 + 1 Then 　　　If Ncol > LastC Then Exit For 　　　NLcol = LastC 　　Else 　　　NLcol = ActiveSheet.VPageBreaks(j).Location.Column - 1 　　End If 　　Nrow = 1 　　'縦方向改ページ分繰り返し　　For i = 1 To Lastpage + 1 　　　If i = Lastpage + 1 Then 　　　　If Nrow > LastR Then Exit For 　　　　NLrow = LastR 　　　Else 　　　　NLrow = ActiveSheet.HPageBreaks(i).Location.Row - 1 　　　End If 　　　With Range(Cells(Nrow, Ncol), Cells(NLrow, NLcol)) 　　　　.Borders(xlEdgeLeft).LineStyle = xlContinuous 　　　　.Borders(xlEdgeLeft).Weight = xlMedium 　　　　.Borders(xlEdgeTop).LineStyle = xlContinuous 　　　　.Borders(xlEdgeTop).Weight = xlMedium 　　　　.Borders(xlEdgeBottom).LineStyle = xlContinuous 　　　　.Borders(xlEdgeBottom).Weight = xlMedium 　　　　.Borders(xlEdgeRight).LineStyle = xlContinuous 　　　　.Borders(xlEdgeRight).Weight = xlMedium 　　　End With 　　　Nrow = NLrow + 1 　　Next 　　Ncol = NLcol + 1 　Next 　'改ページプレビュー、画面の固定を戻す　ActiveWindow.View = xlNormalView 　Application.ScreenUpdating = True End Sub 　　この使い方は、マクロの使い方(１)標準モジュールにあります。　　罫線の種類については、罫線の定数をご覧ください
23	データのある範囲に罫線を引くには？
Sub test1() 　Dim r1 As Long, c1 As Integer, r2 As Long, c2 As Integer 　With ActiveSheet.UsedRange 　　r1 = .Row 　　　　　　　　　　　　　　　　　　　　　　　'入力範囲内先頭行　　c1 = .Column 　　　　　　　　　　　　　　　　　　　　　'入力範囲内先頭列　　r2 = .Row + .Rows.Count - 1 　　　　　　　　　　　　'入力範囲内最終行　　c2 = .Column + .Columns.Count - 1　　　　　　　　 '入力範囲内最終列　End With 　With Range(Cells(r1, c1), Cells(r2, c2)) 　　.Borders(xlEdgeLeft).LineStyle = xlContinuous　　　　　 '選択範囲の左側に縦線　　.Borders(xlEdgeTop).LineStyle = xlContinuous 　　　　　'選択範囲の上側に横線　　.Borders(xlEdgeBottom).LineStyle = xlContinuous 　　　'選択範囲の下側に横線　　.Borders(xlEdgeRight).LineStyle = xlContinuous 　　　　'選択範囲の右側に縦線　　If .Rows.Count > 1 Then _ 　　　　　　　.Borders(xlInsideHorizontal).LineStyle = xlContinuous 　　　'選択範囲が複数行の場合セル間に横線　　If .Columns.Count > 1 Then _ 　　　　　　　.Borders(xlInsideVertical).LineStyle = xlContinuous 　　　　'選択範囲が複数列の場合セル間に縦線　　' .Borders(xlDiagonalDown).LineStyle = xlContinuous 　　　　　　　　'選択範囲の各セルに右下がりの斜線　　' .Borders(xlDiagonalUp).LineStyle = xlContinuous 　　　　　　　　　　'選択範囲の各セルに右上がりの斜線　End With End Sub 　　この使い方は、マクロの使い方(１)標準モジュールにあります。
Sub test2() 　With ActiveSheet.UsedRange 　　.Select 　　.Borders(xlEdgeLeft).LineStyle = xlContinuous　　　　　 '選択範囲の左側に縦線　　.Borders(xlEdgeTop).LineStyle = xlContinuous 　　　　　'選択範囲の上側に横線　　.Borders(xlEdgeBottom).LineStyle = xlContinuous 　　　'選択範囲の下側に横線　　.Borders(xlEdgeRight).LineStyle = xlContinuous 　　　　　'選択範囲の右側に縦線　　If Selection.Rows.Count > 1 Then _ 　　　　　　　.Borders(xlInsideHorizontal).LineStyle = xlContinuous 　　'選択範囲が複数行の場合セル間に横線　　If Selection.Columns.Count > 1 Then _ 　　　　　　　.Borders(xlInsideVertical).LineStyle = xlContinuous 　　　　'選択範囲が複数列の場合セル間に縦線　　' .Borders(xlDiagonalDown).LineStyle = xlContinuous 　　　　　　　　'選択範囲の各セルに右下がりの斜線　　' .Borders(xlDiagonalUp).LineStyle = xlContinuous 　　　　　　　　　　'選択範囲の各セルに右上がりの斜線　End With End Sub 　　この使い方は、マクロの使い方(１)標準モジュールにあります。
24	既存の塗りつぶし色・罫線色を、色の選択ボックスから他の色を指定して変更するには？ http://www.ae.wakwak.com/~efc21/cgi-bin/wwwlng.cgi?print+200209/02090384.txt　　「セルと罫線の色を一気に変更するには」　【VBAラウンジ】
Sub ChColor3() 　Dim ccode As Long, chcode As Long, cicode As Long, cjcode As Long, ckcode As Long 　Dim hani As Range, Accl As Range, rngCell As Range, insh As String 　On Error Resume Next 　ActiveCell.Select 　insh = ActiveSheet.Name 　Set hani = Application.InputBox("色を置換する範囲をドラッグしてください", Type:=8) 　If hani Is Nothing Then MsgBox "キャンセルされました": GoTo ErrStp 　If hani.Areas.Count > 1 Then MsgBox "複数選択不可です": GoTo ErrStp 　If hani.Parent.Name <> insh Then MsgBox "シートは変更不可です": GoTo ErrStp 　Set Accl = Application.InputBox("検索する色のセルをクリックしてください", Type:=8) 　If Accl Is Nothing Then MsgBox "キャンセルされました": GoTo ErrStp 　If Accl.Count <> 1 Then MsgBox "複数選択不可です": GoTo ErrStp 　If Accl.Parent.Name <> insh Then MsgBox "シートは変更不可です": GoTo ErrStp 　On Error GoTo 0 　cjcode = Accl.Interior.ColorIndex 　Accl.Select 　MsgBox "次のダイアログでは置換後の新しいセル色を選択してください" 　If Application.Dialogs(xlDialogPatterns).Show = False Then GoTo ErrStp 　ckcode = Accl.Interior.ColorIndex 　ActiveSheet.Range("A1").Select 　ccode = ActiveCell.Interior.ColorIndex 　MsgBox "次のダイアログでは置換前の罫線色を選択してください" 　If Application.Dialogs(xlDialogPatterns).Show = False Then GoTo ErrStp 　cicode = ActiveCell.Interior.ColorIndex 　If cicode = -4142 Then cicode = -4105 　MsgBox "次のダイアログでは置換後の罫線色を選択してください" 　If Application.Dialogs(xlDialogPatterns).Show = False Then GoTo ErrStp 　chcode = ActiveCell.Interior.ColorIndex 　If chcode = -4142 Then chcode = -4105 　Application.ScreenUpdating = False 　For Each rngCell In hani 　　With rngCell 　　　If .Interior.ColorIndex = cjcode Then .Interior.ColorIndex = ckcode 　　　If .Borders(xlEdgeTop).ColorIndex = cicode Then _ 　　　　.Borders(xlEdgeTop).ColorIndex = chcode 　　　If .Borders(xlEdgeBottom).ColorIndex = cicode Then _ 　　　　.Borders(xlEdgeBottom).ColorIndex = chcode 　　　If .Borders(xlEdgeLeft).ColorIndex = cicode Then _ 　　　　.Borders(xlEdgeLeft).ColorIndex = chcode 　　　If .Borders(xlEdgeRight).ColorIndex = cicode Then _ 　　　　.Borders(xlEdgeRight).ColorIndex = chcode 　　End With 　Next 　ErrStp: 　ActiveCell.Interior.ColorIndex = ccode 　Set rngCell = Nothing: Set Accl = Nothing: Set hani = Nothing 　Application.ScreenUpdating = True End Sub 　　この使い方は、マクロの使い方(１)標準モジュールにあります。
25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40