snasui.com ยินดีต้อนรับ ยินดีต้อนรับสู่กระดานถามตอบ Excel and VBA และอื่น ๆ ที่เป็นมิตรกับทุกท่าน มีไฟล์แนบมหาศาล ช่วยให้ท่านค้นหาและติดตามศึกษาได้โดยง่าย สมาชิกท่านใดที่ยังไม่ได้ระบุ Version ของ Excel ที่ใช้งานจริง สามารถทำตาม Link นี้เพื่อจะได้รับคำตอบที่ตรงกับ Version ของท่านครับ ระบุ Version ของ Excel
Sub InsertRow()
Dim r As Range, rAll As Range
Dim rFmt As Range, rsHead As Range
Dim rtHead As Range, rInsert As Range
With Sheets("Sheet1")
Set rFmt = .Range("A2")
Set rsHead = .Range("A1:F1")
End With
With Sheets("Sheet4")
Set rtHead = .Range("A1")
Set rAll = .Range("D2", .Range("D" & Rows.Count).End(xlUp))
For Each r In rAll
If r <> r.Offset(4, 0) Then
r.Offset(1, 6) = True
End If
Next r
Set rInsert = .Range("I:I").SpecialCells(xlCellTypeConstants)
For Each r In rInsert
r.Resize(2, 1).EntireRow.Insert shift:=xlShiftDown
r.Offset(-2, -7) = "Total"
r.Offset(-2, -4).Formula = "=sum(" & r.Offset(-3, -4).Address & ":" & _
r.Offset(-3, -4).End(xlUp).Address & ")"
Set r = r.Offset(-2, -4)
r = Application.ConvertFormula(r.FormulaR1C1, xlR1C1, xlA1, xlRelative)
r.Resize(1, 4).FillRight
rFmt.Copy
r.CurrentRegion.PasteSpecial xlPasteFormats
Next r
.Range("I:I").Clear
End With
rsHead.Copy rtHead
End Sub