Macros to VBA

ArhamRajput · Mar 17th 2020

Dear Experts i'm using below Macros to run my sheet according to requirements but i need to squeeze (Short) this code like VBA.

Please Help

Code

Sub Conversion()

    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("A:A").Select
    Selection.Delete Shift:=xlToLeft
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "=RC[-1]&"", ""&RC[-3]&"" ""&RC[-2]"
    Range("D1").Select
    Selection.Copy
    Range("D2:D7733").Select
    ActiveSheet.Paste
    Columns("D:D").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("D:D").Select
    Selection.Replace What:=",  ", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("E1").Select
    Application.CutCopyMode = False
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:J").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Columns("H:AF").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:I").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:C").Select
    Selection.Delete Shift:=xlToLeft
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "N Show"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "O Ins"
    Columns("F:F").Select
    Selection.Cut
    Range("C1").Select
    Selection.Insert Shift:=xlToRight
    Range("C1").Select
    ActiveWindow.SmallScroll Down:=-6
    Columns("G:G").Select
    Selection.Cut
    Range("A1").Select
    Selection.Insert Shift:=xlToRight
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "O Ins Name"
    Columns("E:E").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("A1").Select
    Columns("F:F").Select
    Selection.Replace What:="Female", Replacement:="F", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="Male", Replacement:="M", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Columns("G:G").Select
    Selection.Cut
    Columns("F:F").Select
    Selection.Insert Shift:=xlToRight
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    Range("G1").Select
    ActiveCell.FormulaR1C1 = "Age"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "=YEARFRAC(RC[-1],RC[-3])"
    Columns("G:G").Select
    Selection.NumberFormat = "0.0000"
    Range("G2").Select
    Selection.Copy
    Range("G3:G7733").Select
    ActiveSheet.Paste
    Columns("G:G").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("G1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("G1").Select
    Application.CutCopyMode = False
    Columns("G:G").Select
    Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Range("A1").Select
        Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "=PROPER(RC[1])"
    Range("E1").Select
    Selection.Copy
    Range("E2:E7733").Select
    ActiveSheet.Paste
    Columns("E:E").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("F:F").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("E:E").EntireColumn.AutoFit
    Columns("E:E").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("E2").Select
    ActiveWindow.SmallScroll Down:=-12
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight
    Range("E1").Select
    ActiveCell.FormulaR1C1 = "=TRIM(RC[1])"
    Range("E1").Select
    Selection.Copy
    Range("E2:E7733").Select
    ActiveSheet.Paste
    Columns("E:E").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("F1").Select
    Application.CutCopyMode = False
    Columns("F:F").Select
    Selection.Delete Shift:=xlToLeft
    Columns("E:E").EntireColumn.AutoFit
    Columns("E:E").Select
    Selection.FormatConditions.AddUniqueValues
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    Selection.FormatConditions(1).DupeUnique = xlDuplicate
    With Selection.FormatConditions(1).Font
        .Color = -16383844
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 13551615
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("A1").Select
Columns("G:G").Select
    Selection.NumberFormat = "0.0000"
    Range("A1").Select
End Sub

Display More

**royUK** · Mar 17th 2020

I'm not sure what you mean, your code can be improved by not selecting.

ArhamRajput · Mar 17th 2020

Alright i will share sheet what i want to do.

ArhamRajput · Mar 17th 2020

royUK

Here is the Attached file and i have create some Code to do this which is incomplete Please made required changes and update the code according to requirements.

Sheet 1 has Data and Sheet2 has result

Code

Sub MyVBACODE()

Dim i As Integer


Range("A:A,G:G,I:AG,AI:AZ").EntireColumn.Delete

Columns("A:A").Insert Shift:=xlToRight

For i = 2 To 10000

Cells(i, 1).Value = Cells(i, 4) & ", " & Cells(i, 2) & " " & Cells(i, 3)


Next i

Range("B:D").EntireColumn.Delete

Columns("A:G").Insert Shift:=xlToRight

Range("L:L").Cut Range("A:A")

Range("K:K").Cut Range("D:D")
Range("H:H").Cut Range("E:E")
Range("J:J").Cut Range("F:F")
Range("i:I").Cut Range("G:G")

worksheet.range("




End Sub

Display More

ArhamRajput · Mar 17th 2020

royUK

Please Help?

ArhamRajput · Mar 17th 2020

https://www.mrexcel.com/board/…ba-code-required.1127820/

ArhamRajput · Mar 18th 2020

royUK

waiting for response.

**royUK** · Mar 18th 2020

Yes and I'm busy! You also need to post a link on Mr Excel to this post.

ArhamRajput · Mar 18th 2020

I have provided the link over there.

ArhamRajput · Mar 18th 2020

Waiting for Resolution

ArhamRajput · Mar 18th 2020

Here is Complete Code which is need to be perefect according to VBA.

Code

Sub MyVBACODE2()
Application.ScreenUpdating = False
Dim i As Integer
Range("G:G,I:AG,AI:AZ").EntireColumn.Delete
Columns("A:A").Insert Shift:=xlToRight
LastRow = Range("C" & Rows.Count).End(xlUp).Row
For i = 2 To LastRow
Cells(i, 5).Value = Trim(Cells(i, 5) & ", " & Cells(i, 3) & " " & Cells(i, 4))
Next i
Range("I:I").Cut Range("A:A")
Range("B:C").ClearContents
Range("H:H").Cut Range("D:D")
Range("F:F").Cut Range("J:J")
Range("F:F").EntireColumn.Delete

Range("G2:G" & LastRow).FormulaR1C1 = "=YEARFRAC(RC[-1],RC[-3])"

Range("G1") = "Age"
Columns("A:I").EntireColumn.AutoFit
Range("H:H").EntireColumn.Delete

    Range("I1").Select
    ActiveCell.FormulaR1C1 = "Sex"
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-1]=""Male"",""M"",""F"")"
    Range("I2").Select
    Selection.AutoFill Destination:=Range("I2:I159")
    Range("I2:I159").Select
    Columns("I:I").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Range("H:H").EntireColumn.Delete
    Range("G:G").Select
    Selection.Style = "Comma"
    Application.ScreenUpdating = True
End Sub

Display More

Fluff13 · Mar 18th 2020

Also posted here

https://chandoo.org/forum/thre…o-complete-actioin.43857/

**royUK** · Mar 18th 2020

Can we have all links posted here. I also want you to confirm you have read our Forum Rules and understand them. If you do not reply within one hour then I will close this Thread!

ArhamRajput · Mar 18th 2020

There were 2 links and have been adde.

https://chandoo.org/forum/thre…o-complete-actioin.43857/

**royUK** · Mar 18th 2020

You haven't added them. They have been reported by other members. The rules about cross posting are the same on all Excel Forums.

Have you read our rules yet?

ArhamRajput · Mar 18th 2020

Yes!

Macros to VBA

Participate now!

Share