If / Loop / Merge

deadlyjack

New Member
Joined
Aug 21, 2021
Messages
14
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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:
VBA Code:
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

VBA Code:
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

Well-known Member
Joined
Oct 22, 2012
Messages
2,680
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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
VBA Code:
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:
VBA Code:
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
 

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

deadlyjack

New Member
Joined
Aug 21, 2021
Messages
14
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
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 :unsure:

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

Well-known Member
Joined
Oct 22, 2012
Messages
2,680
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
For Dynamic Range, I add Lr for Finding Last row. For A I add Two Line to Code.
Try this:
VBA Code:
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
 

Forum statistics

Threads
1,147,559
Messages
5,741,808
Members
423,689
Latest member
Jords998

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top