VBA code for creating new worksheet based on macros

[mailashish123]

[FONT=&quot]Raw data is in "Sheet1" of WB named as " Contact Details " and located in “E:\Excel”[/FONT]
[FONT=&quot]My code is in module1 of WB named as “Macro code for Contact Details” having a Button on Sheet and the code is given below:[/FONT]
[FONT=&quot]
[/FONT]
<code class="s1w8oh2o-7 bpZJor" style="margin: 0px; padding: 0px; border: 0px; font-style: inherit; font-variant: inherit; font-stretch: inherit; font-size: 13px; line-height: 20px; font-family: "Noto Mono", Menlo, Monaco, Consolas, monospace; vertical-align: baseline; background: transparent; color: rgb(34, 34, 34); max-width: 100%; overflow: auto;">Option Explicit
Sub Contacts_Numbers_New()

Range("1:11").Rows.Hidden = False
Range("1:11").Rows.Delete

Columns("A").UnMerge

Dim LC As Integer 'For dynamic deletion of columns C to Last non blank column

LC = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, 3), Cells(1, LC)).EntireColumn.Delete

Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "B").End(xlUp).Row

Range("C2:H2").Select
Selection.FormulaArray = "=IF(RC[-2]<>"""",TRANSPOSE(RC[-1]:R[5]C[-1]),"""")"
Selection.AutoFill Destination:=ActiveCell.Range("A1:F" & Lastrow - 1)

Range("C2:H" & Lastrow).Select

Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Columns("A:H").AutoFit
Range("A1:A" & Lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Columns("A:B").Delete
Range("1:1").EntireRow.Delete

Range("A:A").EntireColumn.Insert

Dim i As Integer

Dim Lastrownew As Long
Lastrownew = Cells(Rows.Count, "B").End(xlUp).Row

For i = 1 To Lastrownew
Cells(i, 1).Value = i
Next i

Range("A1").EntireRow.Insert

Range("A1").Value = "Sl No."
Range("B1").Value = "Vendor Name"
Range("C1").Value = "Owner"
Range("D1").Value = "Mobile"
Range("E1").Value = "Country"
Range("F1").Value = "Email"
Range("G1").Value = "Vendor Code"

Columns("A:G").AutoFit

End Sub
</code>[FONT=&quot]What editing shall i do in the above code to get the desired output i.e.[/FONT]
[FONT=&quot]On clicking the button on Sheet1 of the WB where the code is written[/FONT]
[FONT=&quot]It should refer to the WB which contains the raw data and process it and gives the structured data in a new workbook and the new WB will get generated in the same folder with Workbook name as “Contact Details Rev01” & Worksheet name as “New Contact Details”[/FONT]
[FONT=&quot]
[/FONT]
[FONT=&quot]Kindly bear with me as I am new to VBA.[/FONT]

 

[JLGWhiz]

You can create a new workbook without using a button by adding a couple of lines to the existing code. See red font below. If you still want a button, extract those lines and put them in their own Sub procedure.

Option Explicit
Sub Contacts_Numbers_New()
Range("1:11").Rows.Hidden = False
Range("1:11").Rows.Delete
Columns("A").UnMerge
Dim LC As Integer 'For dynamic deletion of columns C to Last non blank column
LC = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, 3), Cells(1, LC)).EntireColumn.Delete
Dim Lastrow As Long
Lastrow = Cells(Rows.Count, "B").End(xlUp).Row
    With Range("C2:H2")
        .FormulaArray = "=IF(RC[-2]<>"""",TRANSPOSE(RC[-1]:R[5]C[-1]),"""")"
        .AutoFill Destination:=ActiveCell.Range("A1:F" & Lastrow - 1)
    End With
    With Range("C2:H" & Lastrow)
        .Copy
        .PasteSpecial Paste:=xlPasteValues
    End With
Application.CutCopyMode = False
Columns("A:H").AutoFit
Range("A1:A" & Lastrow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Columns("A:B").Delete
Range("1:1").EntireRow.Delete
Range("A:A").EntireColumn.Insert
Dim i As Integer
Dim Lastrownew As Long
Lastrownew = Cells(Rows.Count, "B").End(xlUp).Row
    For i = 1 To Lastrownew
        Cells(i, 1).Value = i
    Next i
Range("A1").EntireRow.Insert
Range("A1").Value = "Sl No."
Range("B1").Value = "Vendor Name"
Range("C1").Value = "Owner"
Range("D1").Value = "Mobile"
Range("E1").Value = "Country"
Range("F1").Value = "Email"
Range("G1").Value = "Vendor Code"
Columns("A:G").AutoFit
[COLOR=#b22222]Sheets ("Contact Details"). Copy
ActiveWorkbook.Sheets(1).Name = "New Contact Details"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs "E:\Excel\Contact Details Rev01", FileFormat:=51
Application.DisplayAlerts = True
ActiveWorkbook.Close False
[/COLOR]End Sub

 

[mailashish123]

Thanks!!

It worked with a little modification.
Solution verified.

 

[JLGWhiz]

You're welcome,
Regards, JLG