Help Me in Reducing VBA Code

[nareshmedarmatila]

I need a help

Is there any chance we can reduce the code ?

Sub ref_no()
'
' Macro for Reference Number
If ActiveSheet.Name = "Sheet1" Then
      MsgBox "Cannot Run macro In This sheet. Try in Another Sheet"
      Exit Sub
   End If
   result = MsgBox("Replacing Existing Data with Reference Number", vbOKCancel + vbQuestion, QC_TOOL)
   If result = vbCancel Then
   Exit Sub
   Else
   Cells.Select
    Selection.ClearContents
    Cells.Select
    Selection.Cut
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
   Sheets("Sheet1").Range("A:A").Copy Range("A1")
   With Range("A:A")
      .EntireColumn.AutoFit
   Sheets("Sheet1").Range("B:B").Copy Range("B1")
   With Range("B:B")
      .EntireColumn.AutoFit
   Sheets("Sheet1").Range("D:D").Copy Range("C1")
   With Range("C:C")
      .EntireColumn.AutoFit
      .TextToColumns Destination:=Range("E1"), DataType:=xlFixedWidth, _
         FieldInfo:=Array(Array(0, 2), Array(3, 2), Array(8, 2), Array(13, 2), Array(17, 2), _
         Array(23, 2), Array(26, 2), Array(31, 2), Array(35, 2), Array(38, 2), Array(43, 2)), _
         TrailingMinusNumbers:=True
Range("A1:O1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Selection.Font.Bold = True
    Rows("1:1").Select
    Selection.AutoFilter
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("F2").Select
   End With
   End With
   End With
   End If
End Sub

FYI: The code is working fine.

 

[Yongle]

Test on a copy of your workbook
(code has not been tested)

Sub ref_no()
'
' Macro for Reference Number
    If ActiveSheet.Name = "Sheet1" Then
        MsgBox "Cannot Run macro In This sheet. Try in Another Sheet"
        Exit Sub

    ElseIf MsgBox("Replacing Existing Data with Reference Number", vbOKCancel + vbQuestion, QC_TOOL) = vbOK Then
        Cells.Delete
        Sheets("Sheet1").Range("A:B").Copy Range("A1")
        Sheets("Sheet1").Range("D:D").Copy Range("C1")
        Application.CutCopyMode = False
        Range("A:C").EntireColumn.AutoFit
    
        Range("C:C").TextToColumns Destination:=Range("E1"), DataType:=xlFixedWidth, _
            FieldInfo:=Array(Array(0, 2), Array(3, 2), Array(8, 2), Array(13, 2), Array(17, 2), _
            Array(23, 2), Array(26, 2), Array(31, 2), Array(35, 2), Array(38, 2), Array(43, 2)), TrailingMinusNumbers:=True
            
        With Range("A1:O1")
            With .Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent1
                .TintAndShade = 0.399975585192419
                .PatternTintAndShade = 0
            End With
            .Font.Bold = True
            .AutoFilter
        End With
        Cells.EntireColumn.AutoFit
        Range("F2").Select   
    End If
End Sub

 

[nareshmedarmatila]

Thank you so Much!

Its working fine!

 

[Yongle]

thanks for your feedback