エクセルのVBAでお願いします。バージョンは2002です。

Question

anglar

38

37もっと見る

85pt

コンピュータ

エクセルのVBAでお願いします。バージョンは2002です。

添付画像の通り左が処理前、右が処理後です。Ａ４セルから下方向に検索していき同じ番号グループでＡ列からＪ列まで、太枠罫線で囲みたいです。なお、Ａ列の入力セル数は任意です。また、このようなシートが20くらいありますので、それぞれで使えるマクロであってほしいです。よろしくお願いします。

回答の条件

1人2回まで
13歳以上

登録：2011/02/27 17:54:45
終了：2011/02/27 19:33:55

No.2

SALINGER34549692011/02/27 19:20:30

35pt

２番目から１１番目なら次ぎのようになります。

７行目が２～１１という意味です。

Sub Macro()
    Dim i As Long
    Dim lastRow As Long
    Dim stRow As Long
    Dim ws As Worksheet
    Dim j As Integer
    
    For j = 2 To 11
        With Worksheets(j)
            lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
            stRow = 4
            For i = 4 To lastRow
                If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
                    With .Range(.Cells(stRow, "A"), .Cells(i, "J"))
                        .Borders(xlEdgeTop).Weight = xlThick
                        .Borders(xlEdgeBottom).Weight = xlThick
                        .Borders(xlEdgeRight).Weight = xlThick
                        .Borders(xlEdgeLeft).Weight = xlThick
                    End With
                    stRow = i + 1
                End If
            Next i
        End With
    Next
End Sub

任意のシート１枚を除外するとかなら、そのシートに一時的に空のA列を挿入すればいいです。

はい、すべてできています。素早い回答（解答）ありがとうございました。いつもすみません。

2011/02/27 19:32:54

anglar 2011/02/27 20:07:44

終了後、再度質問していいんでしょうか？だめなら破棄してください。
先ほどの選択範囲を太枠で囲むというのはできていましたが、内部の縦横の細線が書かれていません。さっき気がついた次第です。内部の細線も書いてもらえませんか？
SALINGER 2011/02/27 21:02:50

コード中にこれと似たような箇所が４行ありますでしょ。
更に以下の行を増やしてください。
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
anglar 2011/02/27 21:43:25

重ね重ねありがとうございました。ただ、この部分は自分でもできまして、しかし、なぜかエラーとなります。2行目のものをはずすと当然、横罫が書かれませんが最後まで書くことができまして、外さないと2番目のシートから4番目のシートの途中で止まって、エラーとなっています。こんなことってあるんでしょうか？せっかくやってもらっているのに済みません。
anglar 2011/02/27 21:58:10

分かりました。４番目のシートの途中にＡ列で１つのセルで１グループとなってしまう値のために、つまり一行のみのグループがあったので、エラーとなっていました。エラー処理があればいいのかな？そんなこと、できますか？
SALINGER 2011/02/27 22:03:30

たぶん１行のときに内側の線を設定しようとするとエラーになるみたいですね。
これは２００７では大丈夫だったので油断していました。
追加するコードを次のようにしてください。
If i > stRow Then
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
End If
anglar 2011/02/27 22:13:53

はい、できました。ずっとおつきあいくださいまして、ありがとうございました。ポイントも差し上げられなくて済みません。次回質問してお答えいただいたときに、加算させていただきます。お世話になりました。
SALINGER 2011/02/28 07:50:54

すいません。上記だと１行のときに縦線も入らなかったと思います。正しくは
.Borders(xlInsideVertical).Weight = xlThin
If i > stRow Then
.Borders(xlInsideHorizontal).Weight = xlThin
End If
でした。重ね重ね申し訳ない。
きゃづみぃ 2011/02/28 13:42:28

＞該当のセルをアクティブにして実行してください。

シート？
SALINGER 2011/02/28 18:08:41

あら、シートの間違いですね。でももうそこは使われていない。

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

リクエスト送信済

回答リクエストを送信したユーザーはいません

SALINGER · Accepted Answer · 2011-02-27T18:13:21+09:00

該当のセルをアクティブにして実行してください。

Sub Macro()
    Dim i As Long
    Dim lastRow As Long
    Dim stRow As Long
    
    With ActiveSheet
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        stRow = 4
        For i = 4 To lastRow
            If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
                With .Range(.Cells(stRow, "A"), .Cells(i, "J"))
                    .Borders(xlEdgeTop).Weight = xlThick
                    .Borders(xlEdgeBottom).Weight = xlThick
                    .Borders(xlEdgeRight).Weight = xlThick
                    .Borders(xlEdgeLeft).Weight = xlThick
                End With
                stRow = i + 1
            End If
        Next i
    End With
End Sub

また、２０のシートがブックの全てのシートであるなら、こちらで一括でできます。

Sub Macro()
    Dim i As Long
    Dim lastRow As Long
    Dim stRow As Long
    Dim ws As Worksheet
    
    For Each ws In Worksheets
    With ws
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        stRow = 4
        For i = 4 To lastRow
            If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
                With .Range(.Cells(stRow, "A"), .Cells(i, "J"))
                    .Borders(xlEdgeTop).Weight = xlThick
                    .Borders(xlEdgeBottom).Weight = xlThick
                    .Borders(xlEdgeRight).Weight = xlThick
                    .Borders(xlEdgeLeft).Weight = xlThick
                End With
                stRow = i + 1
            End If
        Next i
    End With
    Next
End Sub

SALINGER · Accepted Answer · 2011-02-27T18:13:21+09:00

該当のセルをアクティブにして実行してください。

Sub Macro()
    Dim i As Long
    Dim lastRow As Long
    Dim stRow As Long
    
    With ActiveSheet
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        stRow = 4
        For i = 4 To lastRow
            If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
                With .Range(.Cells(stRow, "A"), .Cells(i, "J"))
                    .Borders(xlEdgeTop).Weight = xlThick
                    .Borders(xlEdgeBottom).Weight = xlThick
                    .Borders(xlEdgeRight).Weight = xlThick
                    .Borders(xlEdgeLeft).Weight = xlThick
                End With
                stRow = i + 1
            End If
        Next i
    End With
End Sub

また、２０のシートがブックの全てのシートであるなら、こちらで一括でできます。

Sub Macro()
    Dim i As Long
    Dim lastRow As Long
    Dim stRow As Long
    Dim ws As Worksheet
    
    For Each ws In Worksheets
    With ws
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        stRow = 4
        For i = 4 To lastRow
            If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
                With .Range(.Cells(stRow, "A"), .Cells(i, "J"))
                    .Borders(xlEdgeTop).Weight = xlThick
                    .Borders(xlEdgeBottom).Weight = xlThick
                    .Borders(xlEdgeRight).Weight = xlThick
                    .Borders(xlEdgeLeft).Weight = xlThick
                End With
                stRow = i + 1
            End If
        Next i
    End With
    Next
End Sub

エクセルのVBAでお願いします。バージョンは2002です。

ベストアンサー

SALINGER34549692011/02/27 18:13:21

その他の回答（1件）

SALINGER34549692011/02/27 18:13:21ここでベストアンサー

SALINGER34549692011/02/27 19:20:30

コメント（9件)

この質問への反応（ブックマークコメント）