Snasui Excel Forum

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

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