• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Excel VBA Loop until all conditions are satisfied

HansrajR

Member
Can someone help me with with the code for loops in the following flow diagram and data in attached file from Row Number 4 to last non blank row.

74809

VBA Macro for Copy_formula_from_rowNumber3_paste_up_to_last_row is as follows:

Code:
Sub Copy_formula_from_rowNumber3_paste_up_to_last_row()
'
' Copy_formula_from_rowNumber3_paste_up_to_last_row Macro
'
' Keyboard Shortcut: Ctrl+Shift+C
'
    Range("D3:J3").Select
    Selection.Copy
    Range("D4:J190").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveWindow.SmallScroll Down:=-189
    Range("M3").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("M3:M190").Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    ActiveWindow.ScrollRow = 155
    ActiveWindow.ScrollRow = 153
    ActiveWindow.ScrollRow = 150
    ActiveWindow.ScrollRow = 143
    ActiveWindow.ScrollRow = 126
    ActiveWindow.ScrollRow = 103
    ActiveWindow.ScrollRow = 58
    ActiveWindow.ScrollRow = 47
    ActiveWindow.ScrollRow = 28
    ActiveWindow.ScrollRow = 20
    ActiveWindow.ScrollRow = 10
    ActiveWindow.ScrollRow = 6
    ActiveWindow.ScrollRow = 4
    Range("A1").Select
    Application.CutCopyMode = False
End Sub
 

Attachments

  • Data and Flow Diagram.xlsm
    76.1 KB · Views: 2
Please find code I have till now:

Code:
Sub cutentirerowInsert2rowsdown()

Dim rw As Long
Dim L As Integer
Dim M As Integer
Dim N As Integer

With ActiveWorkbook.ActiveSheet
    LastRow = .UsedRange.Rows.Count
    For rw = 4 To LastRow
 
    .Cells(rw, 5).Select
      
        If .Cells(rw, 5) < .Cells(rw, 11) And .Cells(rw + 1, 5) >= .Cells(rw + 1, 11) Then 'If Start date less than Not Before date in the row being inspected and Start date is greater or equal to Not Before date in next row
            
            Do Until .Cells(rw, 5) >= .Cells(rw, 11)
                
                .Cells(rw, 5).EntireRow.Select 'Select entire row
                Selection.Cut
                .Cells(rw + 2, 5).EntireRow.Select
                Selection.Insert Shift:=xlDown
                    
            Loop
            
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row
            
                ElseIf .Cells(rw, 5) < .Cells(rw, 11) And .Cells(rw + 1, 5) < .Cells(rw + 1, 11) Then 'If Start date less than Not Before date in the row being inspected and next row and further succeeding rows
                
                    Do Until .Cells(rw + L, 5) >= .Cells(rw + L, 11)
                        
                        Rows(rw & ":" & rw + L).Select 'Select all rows ElseIf condition is satisfied
                        Selection.Cut
                        .Cells(rw + L + 2, 5).EntireRow.Select 'Ínsert all selected rows under the row whereby Start Date is  greater than Not Before Date
                        Selection.Insert Shift:=xlDown
                    
                        L = L + 1
                    
                    Loop
                    
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row
                
        
        If .Cells(rw, 13) < 11 And .Cells(rw + 1, 13) >= 11 Then
        
            Do Until .Cells(rw, 5) >= .Cells(rw, 11)
        
                .Cells(rw, 13).EntireRow.Select 'Select entire row
                Selection.Cut
                .Cells(rw + 2, 13).EntireRow.Select
                Selection.Insert Shift:=xlDown
                    
            Loop
            
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row
            
                ElseIf .Cells(rw, 13) < 11 And .Cells(rw + 1, 13) < 11 Then
                    
                    Do Until .Cells(rw + M, 5) >= .Cells(rw + M, 11)
                    
                        Rows(rw & ":" & rw + M).Select
                        Selection.Cut
                        .Cells(rw + M + 2, 13).EntireRow.Select
                        Selection.Insert Shift:=xlDown
                    
                        M = M + 1
                        
                    Loop
                    
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row
            
        
         If .Cells(rw, 5) > .Cells(rw, 12) And .Cells(rw + 1, 5) <= .Cells(rw + 1, 12) Then
            
            Do Until .Cells(rw, 5) <= .Cells(rw, 12)
                
                .Cells(rw, 5).EntireRow.Select
                Selection.Cut
                .Cells(rw - 1, 5).EntireRow.Select
                Selection.Insert Shift:=xlDown
                    
            Loop
            
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row
            
                ElseIf .Cells(rw, 5) < .Cells(rw, 11) And .Cells(rw + 1, 5) < .Cells(rw + 1, 11) Then
                
                    Do Until .Cells(rw - N, 5) >= .Cells(rw - N, 11)
                        
                        Rows(rw & ":" & rw + L).Select
                        Selection.Cut
                        .Cells(rw - N - 1, 5).EntireRow.Select
                        Selection.Insert Shift:=xlDown
                    
                        N = N + 1
                    
                    Loop
                    
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row
              
        End If
      
      Call Copy_formula_from_rowNumber3_paste_up_to_last_row
      
    Next rw

End With

End Sub
 
Ignore previous

I have got to the following code but getting Compile Error: Next without For

*Kindly find VBA Macro for Copy_formula_from_rowNumber3_paste_up_to_last_row in the question

Code:
Sub cutentirerowInsert2rowsdown()

Dim rw As Long
Dim L As Integer
Dim M As Integer
Dim N As Integer

With ActiveWorkbook.ActiveSheet
    LastRow = .UsedRange.Rows.Count
    For rw = 4 To LastRow
 
    .Cells(rw, 5).Select 'Select Cell in row with Start date "E"
      
        If .Cells(rw, 5) < .Cells(rw, 11) And .Cells(rw + 1, 5) >= .Cells(rw + 1, 11) Then 'If, in selected row, Start "E" < Not Before "K" and in next row Start "E" >= Not Before "K"
            
            Do Until .Cells(rw, 5) >= .Cells(rw, 11) 'Until, in selected row Start "E" >= Not Before "K"
                
                .Cells(rw, 5).EntireRow.Select 'Select row
                Selection.Cut 'Cut row
                .Cells(rw + 2, 5).EntireRow.Select 'Select 2 rows down
                Selection.Insert Shift:=xlDown 'Insert previously cut row
                    
            Loop
            
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
            
                    ElseIf .Cells(rw, 5) < .Cells(rw, 11) And .Cells(rw + 1, 5) < .Cells(rw + 1, 11) Then 'If, in both selected row and next row, Start "E" < Not Before "K"
                    
                        Do Until .Cells(rw + L + 1, 5) >= .Cells(rw + L + 1, 11) 'Until, Start "E" >= Not Before "K" in row after loop
                            
                            Rows(rw & ":" & rw + L).Select 'Select all rows until Start "E" >= Not Before "K" in row after loop
                            Selection.Cut 'Cut all rows in loop
                            .Cells(rw + L + 2, 5).EntireRow.Select 'Ínsert all selected rows under the row whereby Start Date "E" >= Not Before "K" after loop
                            Selection.Insert Shift:=xlDown
                        
                            L = L + 1 'Count Number of Loops
                            
                        Loop
                    
                        Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
            
            
            Else: .Cells(rw, 13).Select 'Select Cell in row with Age "M"
                
                
        If .Cells(rw, 13) < 11 And .Cells(rw + 1, 13) >= 11 Then 'If, in selected row, Age "M" < 11 and in next row Age "M" >= 11
        
            Do Until .Cells(rw, 13) >= 11 'Ín selected row Age "M" >= 11
        
                .Cells(rw, 13).EntireRow.Select 'Select entire row
                Selection.Cut 'Cut row
                .Cells(rw + 2, 13).EntireRow.Select  'Select 2 rows down
                Selection.Insert Shift:=xlDown 'Insert previously cut row
                    
            Loop
            
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
            
                ElseIf .Cells(rw, 13) < 11 And .Cells(rw + 1, 13) < 11 Then 'If, in both selected row and next row Age "M" < 11
                    
                    Do Until .Cells(rw + M + 1, 13) >= 11 'Until, Age "M" >= 11 in row after loop
                    
                        Rows(rw & ":" & rw + M).Select 'Select all rows until Age "M" >= 11 in row after loop
                        Selection.Cut 'Cut all rows in loop
                        .Cells(rw + M + 2, 13).EntireRow.Select 'Ínsert all selected rows under the row whereby Age >= 11 after loop
                        Selection.Insert Shift:=xlDown
                    
                        M = M + 1 'Count Number of Loops
                        
                    Loop
                    
                    Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
            
            Else: .Cells(rw, 5).Select 'Select Cell in row with Start date
        
         If .Cells(rw, 5) > .Cells(rw, 12) And .Cells(rw + 1, 5) <= .Cells(rw + 1, 12) Then 'If, in selected row, Start "E" > Not After "L" and in next row Start "E" <= Not After "L"
            
            Do Until .Cells(rw, 5) <= .Cells(rw, 12) 'Until, in selected row Start "E" <= Not After "L"
                
                .Cells(rw, 5).EntireRow.Select 'Select entire row
                Selection.Cut 'Cut row
                .Cells(rw - 1, 5).EntireRow.Select 'Select 2 rows above
                Selection.Insert Shift:=xlDown 'Insert previously cut row 2 rows above
                    
            Loop
            
            Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
            
                ElseIf .Cells(rw, 5) < .Cells(rw, 12) And .Cells(rw + 1, 5) < .Cells(rw + 1, 12) Then 'If, in both selected row and next row Start "E" > Not After "L"
                
                    Do Until .Cells(rw + N + 1, 5) >= .Cells(rw + N + 1, 12) 'Until, Start "E" <= Not After "L" in row after loop
                        
                        Rows(rw & ":" & rw + L).Select 'Select all rows until Start "E" <= Not After "L" in row after loop
                        Selection.Cut 'Cut all rows in loop
                        .Cells(rw - 1, 5).EntireRow.Select 'Select 2 rows above
                        Selection.Insert Shift:=xlDown 'Insert previously cut row 2 rows above
                    
                        N = N + 1 'Count Number of Loops
                    
                    Loop
                    
                Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
              
            Else: .Cells(rw, 5).Select 'Select Cell in row with Start date
        
        End If
      
        Call Copy_formula_from_rowNumber3_paste_up_to_last_row 'Re-calculate Start date and Age as from Row Number 4 by copying formula in Row Number 3 to Row Number 4 upto last row
      
    Next rw 'Next Row

Dim OutPut As Integer

OutPut = MsgBox("Succesessfully Completed the Task.", vbInformation, "Move Rows")

End With

End Sub
 
Back
Top