If / Loop / Merge

[deadlyjack]

I've got a little task where I need to merge 2 rows together IF the value is greater than 11.
I got the first code to work, but this is only for a specific row...
What I need to generate is a dynamic Loop throughout, x = 3 To 33.
In this case I3 is greater than 11, so if this is the case, then I need to jump I4 and continue my loop on I5.
There's probably an easier code for this that won't crash My excel-file, so please, if you have an answer that may reduce useage of RAM, show me an alternative ?

In other words:

If Produktionshall.Cells(x, "I") <= 11 Then
    Range("A4:P4").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range( _
        "B3:B4,C3:C4,D3:D4,E3:E4,F3:F4,G3:G4,H3:H4,I3:I4,J3:J4,K3:K4,L3:L4,M3:M4,O3:O4,P3:P4" _
        ).Select
    Range("P3").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Range("A3").Select
    Selection.Copy
    Range("A4").Select
    ActiveSheet.Paste
    Exit Function
    End If

Sub DrumCount()
myVar = CheckDrums
End Sub

By the way, I'd also need to repeat this process IF I3 greater than 22. Then I'd need to merge 4 rows together in the same way, instead of two rows.

 

[maabadi]

I tell you add it at one line and because you add it to 2 lines you need to also add End if Condition after it Then Macro Should be:
1. at one line

Function CheckDrums()
Dim i As Long, j As Long
If Range("I" & Range("I3:I33").Find(Application.WorksheetFunction.Max(Range("I3:I33"))).Row).MergeCells = True Then Exit Function
Application.ScreenUpdating = False
For i = 33 To 3 Step -1
    Select Case Cells(i, "I")
    Case ""
    GoTo NextCase
     Case Is >= 22
        Range("A" & i + 1 & ":P" & i + 1).Resize(3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        For j = 1 To 16
        If j = 1 Or j = 14 Then
        Cells(i + 3, j).Borders(xlEdgeBottom).Weight = xlThin
        Else
        Range(Cells(i, j), Cells(i + 3, j)).MergeCells = True
        End If
     Next j

    GoTo NextCase
     Case Is >= 11
        Range("A" & i + 1 & ":P" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        For j = 1 To 16
        If j = 1 Or j = 14 Then
        Cells(i + 1, j).Borders(xlEdgeBottom).Weight = xlThin
        Else
        Range(Cells(i, j), Cells(i + 1, j)).MergeCells = True
        End If
     Next j
    End Select
NextCase:
Next i
Application.ScreenUpdating = True
End If
End Function

Sub DrumCount()
myVar = CheckDrums
End Sub

Or at more than one line:

Function CheckDrums()
Dim i As Long, j As Long
If Range("I" & Range("I3:I33").Find(Application.WorksheetFunction.Max(Range("I3:I33"))).Row).MergeCells = True Then
Exit Function
End if
Application.ScreenUpdating = False
For i = 33 To 3 Step -1
    Select Case Cells(i, "I")
    Case ""
    GoTo NextCase
     Case Is >= 22
        Range("A" & i + 1 & ":P" & i + 1).Resize(3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        For j = 1 To 16
        If j = 1 Or j = 14 Then
        Cells(i + 3, j).Borders(xlEdgeBottom).Weight = xlThin
        Else
        Range(Cells(i, j), Cells(i + 3, j)).MergeCells = True
        End If
     Next j

    GoTo NextCase
     Case Is >= 11
        Range("A" & i + 1 & ":P" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        For j = 1 To 16
        If j = 1 Or j = 14 Then
        Cells(i + 1, j).Borders(xlEdgeBottom).Weight = xlThin
        Else
        Range(Cells(i, j), Cells(i + 1, j)).MergeCells = True
        End If
     Next j
    End Select
NextCase:
Next i
Application.ScreenUpdating = True
End If
End Function

Sub DrumCount()
myVar = CheckDrums
End Sub

 

[deadlyjack]

Hi again,
Sorry for being afk a longer time!
Yeah, I see what I missed, but this code seems to be permanent, meaning that if a row is added with a higher value than 11 in column I, one cannot press the MERGE-button to make sure this new line is merged properly

Also while I'm here, when two or more rows merges together, I want the Cell.Value of column A to be copypasted into the new empty cells created under column A within the merged context.

 

[maabadi]

For Dynamic Range, I add Lr for Finding Last row. For A I add Two Line to Code.
Try this:

Function CheckDrums()
Dim i As Long, j As Long, Lr As Long
Lr = Range("I" & Rows.Count).End(xlUp).Row
If Range("I" & Range("I3:I" & Lr).Find(Application.WorksheetFunction.Max(Range("I3:I33"))).Row).MergeCells = True Then
Exit Function
End If
Application.ScreenUpdating = False
For i = Lr To 3 Step -1
    Select Case Cells(i, "I")
    Case ""
    GoTo NextCase
     Case Is >= 22
        Range("A" & i + 1 & ":P" & i + 1).Resize(3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A" & i + 1).Resize(3) = Range("A" & i)
        For j = 1 To 16
        If j = 1 Or j = 14 Then
        Cells(i + 3, j).Borders(xlEdgeBottom).Weight = xlThin
        Else
        Range(Cells(i, j), Cells(i + 3, j)).MergeCells = True
        End If
     Next j

    GoTo NextCase
     Case Is >= 11
        Range("A" & i + 1 & ":P" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Range("A" & i + 1) = Range("A" & i)
        For j = 1 To 16
        If j = 1 Or j = 14 Then
        Cells(i + 1, j).Borders(xlEdgeBottom).Weight = xlThin
        Else
        Range(Cells(i, j), Cells(i + 1, j)).MergeCells = True
        End If
     Next j
    End Select
NextCase:
Next i
Application.ScreenUpdating = True

End Function

Sub DrumCount()
myVar = CheckDrums
End Sub