How to loop a VBA 4 times

[keranali]

Hi All how do you make this VBA

Sub MoveLeft()
       
       Dim pw     As String
    pw = Application.InputBox("Enter password")
    Select Case pw
        Case "6583546"
 
    
    
    Dim Blnks As Range, B As Range
    Dim LR As Long, r As Long, cols As Long
    
    Const ChkCols As String = "C:E,F:I,K:N"
    
    Application.ScreenUpdating = False
    LR = Range("C" & Rows.Count).End(xlUp).Row
    For r = 2 To LR
        On Error Resume Next
        Set Blnks = Intersect(Rows(r), Range(ChkCols)).SpecialCells(xlCellTypeBlanks)
        On Error GoTo 0
        If Not Blnks Is Nothing Then
            For Each A In Blnks.Areas
                cols = A.Columns.Count
                A.Offset(, cols + 1).Insert Shift:=xlToRight
                A.Delete Shift:=xlToLeft
            Next A
            Set Blnks = Nothing
        End If
    Next r
    Application.ScreenUpdating = True

       Case Else
            Exit Sub
    End Select

End Sub

Run 4 times without having to type the password 4 times


Thanks
K

 

[Trebor76]

Hi keranali,

Try this:

Sub MoveLeft()
       
    Dim pw As String    
    Dim Blnks As Range, _
        B As Range
    Dim LR As Long, _
        r As Long, _
        cols As Long
    Dim intLoopCount As Integer
    
    Const ChkCols As String = "C:E,F:I,K:N"
    
    pw = Application.InputBox("Enter password")
    
    Select Case pw
        Case "6583546"
    
            For intLoopCount = 1 To 4
                Application.ScreenUpdating = False
                LR = Range("C" & Rows.Count).End(xlUp).Row
                For r = 2 To LR
                    On Error Resume Next
                    Set Blnks = Intersect(Rows(r), Range(ChkCols)).SpecialCells(xlCellTypeBlanks)
                    On Error GoTo 0
                    If Not Blnks Is Nothing Then
                        For Each A In Blnks.Areas
                            cols = A.Columns.Count
                            A.Offset(, cols + 1).Insert Shift:=xlToRight
                            A.Delete Shift:=xlToLeft
                        Next A
                        Set Blnks = Nothing
                    End If
                Next r
                Application.ScreenUpdating = True
            Next intLoopCount

       Case Else
            Exit Sub
    End Select

End Sub

HTH

Robert

 

[keranali]

Thanks Very much Robert Worked like a charm

K

 

[Trebor76]

You're welcome