VBAで範囲選択して合計して罫線を引く方法

質問

過去の投稿を見て、似たような物を見つけても
どうしても応用ができません。
重複してしまっているかもしれませんが
宜しくお願い致します。

集計表の一番下にその月が20〆だったら
20　と入力します（例：A37に20と）
すると、21日であるB24から月末のB34の合計が
B37に計算され（来月送りの合計）
20日であるB23のセルの下線又は
21日であるB24のセルの上線が1ptの赤線になる
という自動処理ができるようにしたいのです。
曜日によって18日〆になったり
25日〆になったり　いろいろなので
自動でできると楽になると思いました。
（月末は毎月31日のB34で構いません）

どうぞよろしくお願い致します。

回答No.6

noname#123709 · ベストアンサー

＃1です。
＞シート単位の処理で構わないのですが
下記で現在選択されているシートに限った処理となります。
先ほどの記述内に「.Range("A1").Value = .Range("A1").Value + 1」と
あったのですが、不要でした。すみません。ただエラーとは無関係だと思い
ます。こちらではエラーの再現ができません。型云々なので変数だと思うの
ですが・・・。申し訳ないです。

Sub test()
Dim i As Integer
Application.ScreenUpdating = False
With ActiveSheet
i = .Range("A37").Value
If i >= 1 And i <= 31 Then
.Range("A4:B35").Borders(xlInsideHorizontal).LineStyle = xlNone
.Range(Cells(i + 3, 1), Cells(i + 3, 2)).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
If i = 31 Then
.Range("B37").Value = 0
Else
.Range("B37").Value = "=SUM(B" & i + 4 & ":B34) "
End If
End If
End With
Application.ScreenUpdating = True
End Sub

お礼

素早いお返事ありがとうございました！
そして、今回はエラーも出ず
きれいに処理されました！
すごく嬉しい瞬間でした☆ミ(*^▽^*)ノ彡☆

こちらの不手際で嫌な思いをさせてしまい
すみませんでした。
ありがとうございました！

回答No.5

noname#123709

＞ひとりの人の発言で、全ての人の書いたことを否定はしないでくださいね。
＞こちらの書いていることが無意味になってしまいますから
逆に否定された＃1です。私の理解力がなかったのでしょう。
質問者様に補足して頂いた内容で作成してみましたが下記はBOOKの中のシート
全体に実行します。
２回以上使用される場合もあるかもしれませんので一度罫線を消してから条件に
あった罫線を引きます。

Sub test()
Dim Sh As Worksheet
Dim i As Integer
Application.ScreenUpdating = False
For Each Sh In Worksheets
With Sh
.Select
i = .Range("A37").Value
If i >= 1 And i <= 31 Then
.Range("A4:B35").Borders(xlInsideHorizontal).LineStyle = xlNone
.Range("A1").Value = .Range("A1").Value + 1
.Range(Cells(i + 3, 1), Cells(i + 3, 2)).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 3
End With
If i = 31 Then
.Range("B37").Value = 0
Else
.Range("B37").Value = "=SUM(B" & i + 4 & ":B34) "
End If
End If
End With
Next
Application.ScreenUpdating = True
End Sub

補足

再度のお返事ありがとうございます！
実行すると
”型が一致しません”とメッセージが出て
ＯＫ　で閉じると右隣のシートが表示され
（最後ではなく一つ隣です。右にはまだシートがあります）
元のシートに戻ると
希望通りの処理がなされていました！（ありがとうございます！）

エラーメッセージの理由は
どのようなことが考えられますか？
（自分で、エクセルシート内の不具合に通じることを検証したいのですが）
実際に見ていただかないと無理そうでしたら、
シート単位の処理で構わないのですが
その為にはどこの部分を削除したら
いいのでしょうか？

回答No.4

Wendy02

こんばんは。

私の想像していたレイアウトと、ほとんど狂いはありませんね。ひとりの人の発言で、全ての人の書いたことを否定はしないでくださいね。こちらの書いていることが無意味になってしまいますから。

もし、冷静に私のコードをお読みになっていれば、既に、加工・変更が可能なのでしょうけれども、どうやら、読んではいらっしゃらないようです。今、ブックに加工しなければならない複数のシートがあるようですから、もう少し、手を加えないといけないようですね。

どの程度分るかによって回答も違ってくるように思っています。今のところ、ワークシートメニューの中の、フォーム・ツールバーのコマンドボタンで、各シートにつけていただくのが一番簡単でよいかと思っています。

お礼

今回こちらの不手際で
嫌な思いをさせてしまい
申し訳ありませんでした

ありがとうございました！！

補足

お返事ありがとうございます！

こちらの稚拙な理解力のせいで
失礼してしまい申し訳ありませんでしたm(_ _)m

実行すると
”どこか間違っていませんか？”
と出てしまいます。
しかし、思い通りの処理はされています！ありがとうございます！
このメッセージは何が原因で出るのでしょうか？

回答No.3

Wendy02

こんばんは。

以下は、シートの下のほうのシート・タブを右クリックしてコードの表示で、以下を貼り付けます。貼り付けて、以下の場所に間違いないようでしたら、Alt + Q で画面を閉じたら出来上がりです。

罫線には、ポイントを表す単位はありませんが、「1ptの赤線」は、xlThinに相当します。
A37 に数字を入れさえすれば、罫線が引かれます。

'-----------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　 Dim myDates() As Double

　 '日付入力はどこでしますか？
　 Const INPUTCELL As String = "A37"
　 'B列から何列罫線を引きますか？
　 Const COLUMNCOUNT As Integer = 5

　 If Target.Address(0, 0) <> INPUTCELL Then Exit Sub

　 '日付セルの範囲
　 Set Rng = Range("B4:B34")

　 Application.EnableEvents = False

　 ReDim myDates(Rng.Count)

　 '罫線消去
　 For k = 5 To 12

　　　Rng.Resize(, COLUMNCOUNT).Borders(k).LineStyle = xlNone
　 Next k

　 '日付の検索
　 For Each c In Rng
　　　If IsDate(c.Value) Then
　　　　 myDates(i) = Day(c.Value)
　　　　 Else
　　　　 myDates(i) = c.Value
　　　End If
　　　i = i + 1
　 Next
　 On Error Resume Next
　 j = 0
　 j = WorksheetFunction.Match(Range(INPUTCELL).Value, myDates(), 0)
　 On Error GoTo 0
　 If j = 0 Then MsgBox "どこか間違っていませんか？", vbInformation: GoTo PrcQuit
　 With Rng.Cells(j, 1).Resize(, COLUMNCOUNT).Borders(9)
　　　.LineStyle = xlContinuous
　　　.Weight = xlThin
　　　.ColorIndex = 3
　 End With
　 Set Rng = Nothing
　 Beep
PrcQuit:
　 Application.EnableEvents = True
End Sub

補足

お返事ありがとうございます。
SuperMildさんのご指摘のとおり
説明不足でした。
失礼致しました。

回答No.2

noname#74310

Sub test()
Dim i, j, k As Integer
k = Cells(37, 1)
For i = k To 31
j = j + Cells(i + 4, 2)
Next i
Cells(37, 2) = j
Worksheets("Sheet1").Cells(k + 3, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
Worksheets("Sheet1").Cells(k + 3, 2).Borders(xlEdgeBottom).Weight = xlThin
Worksheets("Sheet1").Cells(k + 3, 2).Borders(xlEdgeBottom).ColorIndex = 3
End Sub

補足

お返事ありがとうございます。
SuperMildさんのご指摘のとおり
説明不足でした。
失礼致しました。

回答No.1

noname#123709

もっと具体的にわかりやすく書けませんか？
＞21日であるB24
他の人にはわかりません。
どんな表になっているのでしょうか？

補足

お返事ありがとうございます！
ひとりよがりの書き方で失礼しました。
月別の人数集計表です。
日付の1日はA4セルから始まっています。

　　　A （日付） 　B（人数）
4　　1　　　　　1
5　　2　　　　　0
6　　3　　　　　2
7　　4　　　　　5
・　　・　　　　・
・　　・　　　　・
・　　・　　　　・
23　20　　　　　3
24　21　　　　　2
・　　・　　　　・
・　　・　　　　・
・　　・　　　　・
34　31　　　　　1
------------------------
35　　　　　　(人数の合計←sum（B4：B34)）
36
37　□　　　　　■（←今まではsum（B24：B34)と手動で入力）
　　↑
　　ここ（A37）にこの月の〆日が20日だったとしたら20と入力すると
■（B37）に21日から31日までの
人数の合計が計算され表示されて（次月送りの合計となります。）
20日のセルの下線が赤線になる・・・というのは、
20日で締めた　とわかりやすいようにしたいのです。
（最初の質問ではヒトツのセルだけでしたが
こうして見ると（A23:B23)のセルの下線を
赤にしたいです）

今までは毎月手動でB37に入れてあるsumの
範囲を変えて罫線の設定をして・・・
とやっているのですが
ブック内のシート全てが同じ締め日だったら
まだいいのですが、
取引先ごとにまちまちなので
シートの複数選択ではできない為
自動でできたらと思い試行錯誤して
全然できなかった次第です。
月ごとの合計も必要　かつ
各取引先の締め日と次月送りもわかりやすく
という意図です。

上の書き方では、どうでしょうか？
宜しくお願いします