Dùng VBA Căn Boder toàn bảng tự động bị merger cell .Help

[dailame9x]

Tình hình là em có cái bẳng như hình bên trái( VD cần căn Border). Em muốn căn mỗi mội số thư tự như bảng bên phải (mẫu Border) giống như định dạng (Format cell) .
Về bảng thì Cột A với Cột D sẽ bị gộp cùng số hàng.
Bác nào có code vòng lặp chọn đc range của vùng D sang A-> Border-> rồi offset xuống dưới lại chọn Range mới giúp e với! Em cảm ơn!

 

[be_09]

Tình hình là em có cái bẳng như hình bên trái( VD cần căn Border). Em muốn căn mỗi mội số thư tự như bảng bên phải (mẫu Border) giống như định dạng (Format cell) .
Về bảng thì Cột A với Cột D sẽ bị gộp cùng số hàng.
Bác nào có code vòng lặp chọn đc range của vùng D sang A-> Border-> rồi offset xuống dưới lại chọn Range mới giúp e với! Em cảm ơn!

Bạn dùng thử File. Bạn muốn thêm dữ liệu bao nhiêu là tùy ý.

 

[dailame9x]

Bạn dùng thử File. Bạn muốn thêm dữ liệu bao nhiêu là tùy ý.

Em muốn là kẻ ô theo số thứ tự trên, bên trong là nét đứt và viền bao là nét liền cho từng mục kiểu như này đó bác

 

[Nhattanktnn]

Em muốn là kẻ ô theo số thứ tự trên, bên trong là nét đứt và viền bao là nét liền cho từng mục kiểu như này đó bác
View attachment 251036

Thử code này xem sao:

Option Explicit
Sub Border()
Dim Lr As Long, WorkRng As Range, Rng As Range
Lr = Cells(Rows.Count, 1).End(xlUp).Row
Lr = Lr + Cells(Lr, 1).MergeArea.Rows.Count - 1
Set WorkRng = Range("A2:A" & Lr)
    For Each Rng In WorkRng
        With Rng.MergeArea.Resize(, 4)
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideVertical).Weight = xlHairline
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
    Next
End Sub

 

[dailame9x]

Thử code này xem sao:

Option Explicit
Sub Border()
Dim Lr As Long, WorkRng As Range, Rng As Range
Lr = Cells(Rows.Count, 1).End(xlUp).Row
Lr = Lr + Cells(Lr, 1).MergeArea.Rows.Count - 1
Set WorkRng = Range("A2:A" & Lr)
    For Each Rng In WorkRng
        With Rng.MergeArea.Resize(, 4)
            .Borders.LineStyle = xlContinuous
            .Borders(xlInsideVertical).Weight = xlHairline
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
    Next
End Sub

Em dùng thử rồi nhưng chưa thấy thay đổi gì bác ơi.

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

Hiện em đang thử code này nhưng không viết đc code cho Range hiện tại để tính toán tiếp có bác nào xem thử giúp e với

Sub Border()
Dim i As Integer
On Error GoTo Last
i = InputBox("Nhap so cong doan", "Co bn cong doan")
For i = 1 To i
' Vung chọn hiện tại
ActiveCell.Offset(1, 0).Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With


Next i
Last: Exit Sub
End Sub

 

[Nhattanktnn]

Em dùng thử rồi nhưng chưa thấy thay đổi gì bác ơi.

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

Hiện em đang thử code này nhưng không viết đc code cho Range hiện tại để tính toán tiếp có bác nào xem thử giúp e với

Sub Border()
Dim i As Integer
On Error GoTo Last
i = InputBox("Nhap so cong doan", "Co bn cong doan")
For i = 1 To i
' Vung chọn hiện tại
ActiveCell.Offset(1, 0).Activate
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlHairline
End With


Next i
Last: Exit Sub
End Sub

Chả biết bạn có biết cách dùng không nữa

 

[dailame9x]

Chả biết bạn có biết cách dùng không nữa

WOw rất oke bác . Em thank bác nhiều nhá.

 

[be_09]

Em muốn là kẻ ô theo số thứ tự trên, bên trong là nét đứt và viền bao là nét liền cho từng mục kiểu như này đó bác

Thêm một cách khác cho bạn.

 

[dailame9x]

Thêm một cách khác cho bạn.

Em cảm ơn bác nhiều nhé! .

 

[be_09]

Em cảm ơn bác nhiều nhé! .

Code sau ngắn gọn hơn:,

Sub Tao_Border()
    Dim CellCuoi As Long, xCell As Range
    CellCuoi = Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1").CurrentRegion.Borders.ColorIndex = xlNone
    Sheet1.Range("A1").CurrentRegion.Borders.LineStyle = xlThin
    Sheet1.Range("A1").CurrentRegion.BorderAround xlContinuous, xlThick
    For Each xCell In Range("A1:A" & CellCuoi)
        xCell.MergeArea.Resize(, 4).Borders(xlEdgeTop).Weight = xlThick
        xCell.MergeArea.Resize(, 4).Borders(xlEdgeBottom).Weight = xlThick
    Next
End Sub

Hoặc sửa code bài 4 thế này:

Sub Border()
    Dim Lr As Long, Rng As Range
    Lr = Cells(Rows.Count, 1).End(xlUp).Row
    Sheet1.Range("A1").CurrentRegion.Borders.ColorIndex = xlNone
    For Each Rng In Range("A1:A" & Lr)
        With Rng.MergeArea.Resize(, 4)
            .Borders.LineStyle = xlContinuous
            .Borders.Weight = xlThick
            .Borders(xlInsideVertical).Weight = xlHairline
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
    Next
End Sub