สอบถามเกี่ยวกับการแทรกแถว โดยให้มีหัวคอลัมภน์มาด้วย

[niwat2811]

รบกวนท่านอาจารย์หรือผู้รู้ช่วยดู Code ให้หน่อยครับ เกี่ยวกับการแทรกแถวโดยใช้ VBA โดยให้มีหัวคอลัมภน์ติดมาด้วย Code อยู่ใน Module1 ชือ Sub InsertRow ครับ

[snasui]

ลองทดสอบ Code ตามด้านล่างครับ

Code: Select all

Sub Insertrow()
    Dim r As Range, rAll As Range
    Dim rHeader As Range
    Dim rInsert As Range
    With Sheets("Sheet2")
        Set rAll = .Range("I6", .Range("I" & Rows.Count).End(xlUp))
        Set rHeader = .Range("A5:I5")
        For Each r In rAll
            If r & r.Offset(0, -1) <> r.Offset(1, 0) & r.Offset(1, -1) _
                And r.Offset(1, 0) <> "" Then
                r.Offset(1, 1) = True
            End If
        Next r
        Set rInsert = .Range("J:J").SpecialCells(xlCellTypeConstants)
            For Each r In rInsert
                r.Resize(4, 1).EntireRow.Insert shift:=xlShiftDown
                r.Offset(-2, -9) = r.Offset(0, -2) & " " & "(" & r.Offset(0, -1) & ")"
                r.Offset(-1, -9).Resize(1, 9) = rHeader.Value
                ActiveCell.HorizontalAlignment = xlLeft
                ActiveCell.Font.Bold = True
            Next r
        .Range("J:J").Clear
    End With
End Sub

[niwat2811]

แจ้งผลครับ Code ที่ท่านอาจารย์ให้มาสามารถใช้งานได้เป็นอย่างดี ตรงกับความต้องการครับ ขอบคุณมากครับ

[niwat2811]

สวัสดีครับ จากที่ได้ลองนำ Code ที่ท่านอาจารย์ให้มาไปลองปรับใช้แล้วพบปัญหาอยู่นิดนึง คือในกรณีที่ประเภทสินเชื่อใด มี "หนี้ปกติ" หรือ "หนี้ค้าง" อยู่บรรทัดเดียวจะเกิด Error ขึ้น ไม่สามารถแทรกแถวได้ ไม่ทราบว่าควรแก้ไข Code อย่างไรดีครับ รบกวนช่วยแนะนำด้วยครับ (บรรทัดที่คิดว่าน่าจะเป็นปัญหาทำให้ Error ผมได้ทำสีแดงไว้แล้วในไฟล์แนบครับ) Code อยู่ใน Module1 ชื่อ InsertRow ครับ

[snasui]

ลองปรับ Code เป็นตามด้านล่าง ซึ่งผมได้แถม Code สำหรับการตีเส้นให้เรียบร้อยแล้วครับ

Code: Select all

Sub InsertRow()
    Dim r As Range, rAll As Range
    Dim rHeader As Range
    Dim j As Integer
    Dim i As Integer
    With Sheets("Sheet2")
        Set rAll = .Range("I6", .Range("I" & Rows.Count).End(xlUp))
        Set rHeader = .Range("A5:I5")
        For Each r In rAll
            If r & r.Offset(0, -1) <> r.Offset(1, 0) & r.Offset(1, -1) _
                And r.Offset(1, 0) <> "" Then
                r.Offset(1, 1) = True
            End If
        Next r
        j = .Range("J:J").SpecialCells(xlCellTypeConstants).Count
        For i = 1 To j
            Set r = .Range("J" & Rows.Count).End(xlUp)
            r.Resize(4, 1).EntireRow.Insert shift:=xlShiftDown
            r.Offset(-2, -9) = r.Offset(0, -2) & " " & "(" & r.Offset(0, -1) & ")"
            r.Offset(-1, -9).Resize(1, 9) = rHeader.Value
            r.ClearContents
        Next i
    End With
'    Call AllFormatCell
    Call CreateFormat
End Sub

Sub CreateFormat()
    Dim rAll As Range
    Dim r As Range
    With Sheets("Sheet2")
        Set rAll = .Range("I:I").SpecialCells(xlCellTypeConstants)
    End With
    For Each r In rAll
        r.Offset(0, -8).Resize(1, 9).Borders.LineStyle = xlContinuous
    Next r
End Sub

[niwat2811]

แจ้งผลครับ ได้ลองปรับ Code ตามที่ท่านอาจารย์ได้แนะนำมา สามารถใช้ได้ตามต้องการเลยครับ ขอบคุณมากครับ