Tắt báo lỗi trong code

[songiang5011]

Em xin chào anh chị trong diễn đàn, em có xin được 1 code, khi chạy ấn ok thì hoạt động bình thường, nhưng khi ấn cancel thì code xuất hiện báo lỗi. vậy phiền anh chị tắt thông báo lỗi khi cancel giúp em với ạ. Em xin cám ơn ạ.

Bài đã được tự động gộp: 1/12/23

Code đây ạ Sub MergeSameCell()

Dim Rng As Range, xCell As Range

Dim xRows As Integer

xTitleId = "Chon vung can gop o"

Set WorkRng = Application.Selection

Set WorkRng = Application.InputBox("Vung gop o", xTitleId, WorkRng.Address, Type:=8)

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xRows = WorkRng.Rows.Count

For Each Rng In WorkRng.Columns

For i = 1 To xRows - 1

For j = i + 1 To xRows

If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then

Exit For

End If

Next

WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge

i = j - 1

Next

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

 

[BuiQuangThuan]

Thêm câu này dưới sub coi sao

On Error Resume Next

 

[zzzsxxx01]

Bạn thử sửa code thành như vậy xem sao.
Option Explicit
Sub MergeSameCell()
Dim i, j As Long
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Dim xTitleId As String
Dim WorkRng As Range

xTitleId = "Chon vung can gop o"
On Error Resume Next
Set WorkRng = Application.Selection
On Error GoTo 0

On Error Resume Next
Set WorkRng = Application.InputBox("Vung gop o", xTitleId, WorkRng.Address, Type:=8)
On Error GoTo 0

Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count

For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
i = j - 1
Next
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[ongke0711]

Nếu lỡ tay bấm xóa mất cái vùng đã tự động chọn sẵn trong InputBox (cái $B$11 như trong hình) - rồi bấm OK thì sao các bạn?

 

[songiang5011]

Bạn thử sửa code thành như vậy xem sao.
Option Explicit
Sub MergeSameCell()
Dim i, j As Long
Dim Rng As Range, xCell As Range
Dim xRows As Integer
Dim xTitleId As String
Dim WorkRng As Range

xTitleId = "Chon vung can gop o"
On Error Resume Next
Set WorkRng = Application.Selection
On Error GoTo 0

On Error Resume Next
Set WorkRng = Application.InputBox("Vung gop o", xTitleId, WorkRng.Address, Type:=8)
On Error GoTo 0

Application.ScreenUpdating = False
Application.DisplayAlerts = False
xRows = WorkRng.Rows.Count

For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
i = j - 1
Next
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Dạ vâng. Em cám ơn