[[20120507105359]]　『範囲選択の方法について』（me）　ページの最後に飛ぶ

『範囲選択の方法について』（me）

こんにちは。
少し前にみなさんのお力を借りたものです。

https://www.excel.studio-kazu.jp/kw/20120402151929.html

今まで不自由なく動作しているのですが少し改善を加えたいと思い、
質問しております。

よろしくお願いします。

教えていただいたコード↓

Dim sh2 As Worksheet

    Dim Target As Range
    Dim c As Range
    Dim sv As Variant
    Dim myR As Range

    Application.ScreenUpdating = False

    Set sh2 = Sheets("Sheet2")
    Set myR = Sheets("Sheet1").Range("B2:J20")

    sv = myR.Formula
    myR.Replace What:="", Replacement:=vbTab, LookAt:=xlWhole
    myR.Value = myR.Value
    myR.Interior.ColorIndex = xlNone

    For Each c In sh2.Range("A1", sh2.Range("A" & sh2.Rows.Count).End(xlUp))
        myR.Replace What:=c.Value, Replacement:="", LookAt:=xlWhole
    Next

    On Error Resume Next
    Set Target = myR.Cells.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not Target Is Nothing Then Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
    If Not Target Is Nothing Then Target.Borders(xlDiagonalUp).Weight = xlHairline
    myR.Formula = sv
　　（↑を斜線を引くように変更しました。）
    myR.Formula = sv

    Set sh2 = Nothing
    Set myR = Nothing
    Set Target = Nothing

    Application.ScreenUpdating = True

この斜線は一致したセルを対象としていますが、
これを一致したセルから下8行目までに斜線を入れたいです。
（例：一致したセルがA1のときにA1の右上からA9の左下へ斜線が引かれるようにしたい）

すみませんが
どなたかお助けください。
どうかよろしくおねがいします。

（me）

 参照としてあげてある前トピのコードと、今回アップされているコードは、ちょっと違うような気もするけど？

 それはともあれ。

 まず、セルの罫線としての斜め線は、あくまで　セルに対して引かれるので仮に、Ａ１～Ａ９に対して行ったとして
 Ａ１，Ａ２，Ａ３，・・・Ａ９の各セルに、それぞれ引かれる。
 イメージしているのは、そうじゃなく、Ａ１～Ａ９の全体に対して、左上から右下に１本の斜線を引くんだよね？

 どうしても、これをやるなら
・結合セルにして、斜線を引く
・あるいは罫線ではなく、図形としての線を斜めに引く。

 このいずれかになると思うけど？

 追伸）アップされたコードはざらっと眺めただけだし、実際のシートがどうなっているのかも見えないけど
　・たとえば A1とA2 が空白の場合、Target は A1:A2 という領域になる。
　　この場合、A1から下にA9 まで、かつ A2から下にA10 まで？？
  ・たとえば A1 と A3 が空白なら　Target は　A1 と　A3 になる。
　　この場合、A1から下にA9 まで、かつ A3から下にA11 まで？？

 (ぶらっと)

すみません；；
実際のコードは以下です。

Dim sh2 As Worksheet

    Dim Target As Range
    Dim c As Range
    Dim sv As Variant
    Dim myR As Range

    Application.ScreenUpdating = False

    Set sh2 = Sheets("sheet2")
    Set myR = Sheets("sheet1").Range("B2:J52")

    sv = myR.Formula
    myR.Replace What:="", Replacement:=vbTab, LookAt:=xlWhole
    myR.Value = myR.Value
    myR.Interior.ColorIndex = xlNone

    For Each c In sh2.Range("B1", sh2.Range("B" & sh2.Rows.Count).End(xlUp))
        myR.Replace What:=c.Value, Replacement:="", LookAt:=xlWhole
    Next

    On Error Resume Next
    Set Target = myR.Cells.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not Target Is Nothing Then Target.Borders(xlDiagonalUp).LineStyle = xlContinuous
    If Not Target Is Nothing Then Target.Borders(xlDiagonalUp).Weight = xlHairline
    myR.Formula = sv

    Set sh2 = Nothing
    Set myR = Nothing
    Set Target = Nothing

    Application.ScreenUpdating = True

分かりにくい説明ですみません；
そうです。Ａ１～Ａ９の全体に対して斜線を引きたいんです。

追伸についてですが、
実際には２列目、１２列目、２２列目…５２列目でしか一致しないのでそのような事は起こらないと思います。

なんだかとても面倒なことをお願いしているようですね；
すみません；

（me)

 >実際には２列目、１２列目、２２列目…５２列目でしか一致しないのでそのような事は起こらないと思います

 ということを信じて？
 シェープの斜線のケース。
 上でもいったように、いやいや、罫線だということなら、セルを９つ結合させて斜線を引くということになるね。

    Dim r As Range
    Dim bgx As Double, bgy As Double, edx As Double, edy As Double

    On Error Resume Next
    Set Target = myR.Cells.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If Not Target Is Nothing Then
        For Each r In Target
            bgx = r.Left + r.Width
            bgy = r.Top
            edx = r.Left
            edy = r.Offset(8).Top + r.Offset(8).Height
            Target.Parent.Shapes.AddLine bgx, bgy, edx, edy
        Next
    End If

 (ぶらっと)

ぶらっとさん

ありがとうございます！
完璧です！
ほんとにたすかりました！！

（me）

コメント返信：

[ 一覧(最新更新順) ]

[[20120507105359]] 『範囲選択の方法について』（me） ページの最後に飛ぶ

[[20120507105359]]　『範囲選択の方法について』（me）　ページの最後に飛ぶ