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]

You want all cell values at merged Cell or only first value?
Because merge only hold first cell value at merged range.

 

[maabadi]

1. Greater than Or less Than. Your macro tell Less Than?

2. You want only merge at column I or merge all columns from A to P?
For example if I3 < 11 Them
Merge
A3:A4
B3:B4
....
I3:I4
....
Or Only

I3:I4

 

[maabadi]

Try this for Less Than Condition and all column merging from A to P:

Sub MergingCR()
Dim i As Long, j As Long
Application.ScreenUpdating = False
For i = 33 To 3 Step -1
    Select Case Cells(i, "I")
    Case ""
    GoTo NextCase
    Case Is <= 11
        Range("A" & i + 1 & ":P" & i + 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        For j = 1 To 16
        Range(Cells(i, j), Cells(i + 1, j)).MergeCells = True
        Next j
        GoTo NextCase
     Case Is <= 22
        Range("A" & i + 1 & ":P" & i + 1).Resize(3).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        For j = 1 To 16
        Range(Cells(i, j), Cells(i + 3, j)).MergeCells = True
        Next j
    End Select
NextCase:
Next i
Application.ScreenUpdating = True
End Sub

 

[deadlyjack]

Thank you Maabadi for a quick response. Yes! This was exactly what I was looking for, but had to change the, Case Is <= 11, to, Case Is >=11. If the value is more than 11, then merge two rows together (1+1), or more than 22, then merge 4 rows together (1+3).

Also I cannot merge Column A & N, because these require to be accessed through our PivotTable with special letters... A-column could copypaste the cell above and paste it into the new row merged together with it.

 

[deadlyjack]

I restructured the code a bit, but it's more to my satisfaction now.
Now I just need to figure out how to give both A & N Bottom Borders, to each specific row.
Not sure what to change if I'd like to leave column A & N out of this equation.... Could you help me with that?

Function CheckDrums()
Dim i As Long, j As Long
Application.ScreenUpdating = False
For i = 19 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
        Range(Cells(i, j), Cells(i + 3, j)).MergeCells = True
     Next j

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

Sub DrumCount()
myVar = CheckDrums
End Sub

 

[maabadi]

If I understand Correct, you want this:

Function CheckDrums()
Dim i As Long, j As Long
Application.ScreenUpdating = False
For i = 19 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 Function

Sub DrumCount()
myVar = CheckDrums
End Sub

 

[deadlyjack]

This works perfectly! Thanks!

Let's say, for the sake of somebody elses safety, that I would like to implement a safezone, where if someone would accidentally press the button two times, the code will not repeat itself on rows that has already been merged... Is this possible to activate somehow?

What I am making is a list that will constantly be filled with new projects. Therefore, all I can think of right now is to add an additional button that will reverse what we just did, then after adding new projects, I could click the Merge-button once again... a merge & unmerge-button by switching .MergeCells = True to .MergeCells = False

But it would've been nicer to have a command that implements this right from the start

I really appretiate all the help you've provided so far maababi!

 

[maabadi]

if someone would accidentally press the button two times, the code will not repeat

Add This after Dim Line

If Range("I" & Range("I3:I30").Find(Application.WorksheetFunction.Max(Range("I3:I30"))).Row).MergeCells = True Then Exit Function

 

[deadlyjack]

I get Run-time error '91':
Object variable or with block variable not set.

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