vba - two different loops into Single Loop....

[Malleshg24]

Hi Team,

Need your help, how to shorten the code , merging two loops into single loop.
In sheet expected output wherein I mentioned expected result. attached code in workbook it works.

Thanks for your help in advance !!

Thanks.
mg

 

[Stevie]

Hi Malleshg24
your query appears to have fallen through he cracks somewhere so I took a few minutes to look at it today.
I have modified your first macro to perform both tasks in either order exactly once on a dynamically sized data-set.
It is unclear from your query if you want it to work this way, but it is my best guess based on your file.

I personally would write some of your code differently to how it is done in your example, but I have not made edits in aid of this as I want it to be easy to see what I have done from your perspective so that you can manage it.

Please try the below code and let me know if it does what you need.
Here is the code:

Public Sub Situations() 'Modified by Stevie on Chandoo.org for Malleshg24 - 30/07/19
Dim lastrow As Long
Dim i As Long
Dim check1 As Boolean: check1 = True
Dim check2 As Boolean: check2 = True
Dim myrange As Range
Application.ScreenUpdating = False
With ActiveSheet
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 3 To lastrow
        If (.Cells(i, "B").Value = 50000 And check1) Or (.Cells(i, "B").Value = "" And .Cells(i - 1, "B").Value <> "" And .Cells(i - 1, "a").Value <> "" And check2) Then
            If .Cells(i, "B") = 50000 Then
                check1 = False
            Else
                check2 = False
            End If
            Set myrange = Cells(i, "B")
            With myrange
                .EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                .EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                i = i + 2
                lastrow = lastrow + 2
                With .Offset(-2, -1).Resize(1, 2).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Weight = xlMedium
                End With
            End With
        End If
    Next i
End With
Application.ScreenUpdating = False
End Sub

If this was helpful, please click 'Like!' in the bottom right!

Stevie

 

[Malleshg24]

Hi Steve

Superb !!!! Thanks a lot for your help and your precious time on this -got the answer as expected.


Thanks
Mallesh