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

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

回答の条件
  • 1人2回まで
  • 13歳以上
  • 登録:2011/02/27 17:54:45
  • 終了:2011/02/27 19:33:55

ベストアンサー

id:SALINGER No.1

SALINGER回答回数3430ベストアンサー獲得回数9692011/02/27 18:13:21

ポイント50pt

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

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

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

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
id:anglar

完璧にできています。感謝です。いつも素早い対応でありがたいです。なお、2つめのコードですが、対象列は現在、2番目のシートから11番目のシートのみです。どのようにしたらいいですか?実は一つ一つやろうと思っていたので、20くらいなんて適当に書いてしまいました。

2011/02/27 19:10:18

その他の回答(1件)

id:SALINGER No.1

SALINGER回答回数3430ベストアンサー獲得回数9692011/02/27 18:13:21ここでベストアンサー

ポイント50pt

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

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

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

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
id:anglar

完璧にできています。感謝です。いつも素早い対応でありがたいです。なお、2つめのコードですが、対象列は現在、2番目のシートから11番目のシートのみです。どのようにしたらいいですか?実は一つ一つやろうと思っていたので、20くらいなんて適当に書いてしまいました。

2011/02/27 19:10:18
id:SALINGER No.2

SALINGER回答回数3430ベストアンサー獲得回数9692011/02/27 19:20:30

ポイント35pt

2番目から11番目なら次ぎのようになります。

7行目が2~11という意味です。


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

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

id:anglar

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

2011/02/27 19:32:54
  • id:anglar
    終了後、再度質問していいんでしょうか?だめなら破棄してください。
    先ほどの選択範囲を太枠で囲むというのはできていましたが、内部の縦横の細線が書かれていません。さっき気がついた次第です。内部の細線も書いてもらえませんか?
  • id:SALINGER
    コード中にこれと似たような箇所が4行ありますでしょ。
    更に以下の行を増やしてください。
    .Borders(xlInsideVertical).Weight = xlThin
    .Borders(xlInsideHorizontal).Weight = xlThin
  • id:anglar
    重ね重ねありがとうございました。ただ、この部分は自分でもできまして、しかし、なぜかエラーとなります。2行目のものをはずすと当然、横罫が書かれませんが最後まで書くことができまして、外さないと2番目のシートから4番目のシートの途中で止まって、エラーとなっています。こんなことってあるんでしょうか?せっかくやってもらっているのに済みません。
  • id:anglar
    分かりました。4番目のシートの途中にA列で1つのセルで1グループとなってしまう値のために、つまり一行のみのグループがあったので、エラーとなっていました。エラー処理があればいいのかな?そんなこと、できますか?
  • id:SALINGER
    たぶん1行のときに内側の線を設定しようとするとエラーになるみたいですね。
    これは2007では大丈夫だったので油断していました。
    追加するコードを次のようにしてください。
    If i > stRow Then
    .Borders(xlInsideVertical).Weight = xlThin
    .Borders(xlInsideHorizontal).Weight = xlThin
    End If
  • id:anglar
    はい、できました。ずっとおつきあいくださいまして、ありがとうございました。ポイントも差し上げられなくて済みません。次回質問してお答えいただいたときに、加算させていただきます。お世話になりました。
  • id:SALINGER
    すいません。上記だと1行のときに縦線も入らなかったと思います。正しくは
    .Borders(xlInsideVertical).Weight = xlThin
    If i > stRow Then
    .Borders(xlInsideHorizontal).Weight = xlThin
    End If
    でした。重ね重ね申し訳ない。
  • id:taknt
    >該当のセルをアクティブにして実行してください。

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

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません