VBA help required: to create multiple workbooks from one workbook and also paste data in those workbooks.

[aman2059]

This forum is really helpful. I have been learning so much from the forum users. First of all thanks all

So I have below questions regarding creating multiple workbooks from one sheet. My steps are

1. There will "first.last name" in Column A. Sort column A for A to Z..
2. For all unique names in the column A, I have to copy data along with data present in column B,C,D against that unique name and then paste it all in the new workbook with the header(row 1). and then save the file with name "first.last"( which is present in column A of the sheet). Just like this, I have to do it for all the unique names present in the excel in column A.

Here is one example -

IF cell A2, A3, and A4 have name Aman.Bhardwaj
So I need all three row items to be copied and pasted into the new workbook along with the header(Row 1) and then it gets saved.

then if there another name in column A such as Aman sharma.
I need to perform same procedure again for this.

I have to do above for all names present in the excel.

Could anyone tell me if it is possible and if it is, please suggest me the code. I am not able to figure out code for this. This looks very advanced to me.

Thanks you in advance.

 

[John Davis]

Maybe:

Sub aman2059()
Dim ws As Worksheet, i As Long, x As String
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
End With
Set ws = ActiveSheet
With ws
    For i = .Range("A" & Rows.Count).End(3).row - 1 To 1 Step -1
    x = .Cells(i + 1, "A").Value
        If .Cells(i + 1, "A") <> .Cells(i, "A") Then
            Workbooks.Add
            ActiveWorkbook.SaveAs x & ".xlsx"
            ActiveSheet.Name = x
            Rows(1).Value = .Rows(1).Value
            .Range("A1:A" & .Range("A" & Rows.Count).End(3).row).AutoFilter 1, .Cells(i + 1, "A")
            .Range("A2:A" & .Range("A" & Rows.Count).End(3).row).SpecialCells(12).Copy Range("A" & Rows.Count).End(3)(2)
            .Cells.Copy
            Range("A1").PasteSpecial xlPasteFormats
            ActiveSheet.Cells.Columns.AutoFit
            'ActiveWorkbook.Close True
        End If
        .Activate
    Next i
End With
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = xlCalculationManual
End With
End Sub

 

[aman2059]

Hi John,

Thank you so much for helping me out.

The above code worked fine. I am facing a small problem - When it copy and paste names from column A in the new workbook, it does copy data present in column B, C, and D against column A . Otherwise, everything is fine.

Could you please help me out?

 

[aman2059]

Also I need to save workbook on the some other location. Example - C:\Users\aman\Desktop\visual\Learning process

 

[John Davis]

You're welcome. Try:

Sub aman2059()
Dim ws As Worksheet, i As Long, x As String
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
End With
Set ws = ActiveSheet
With ws
    For i = .Range("A" & Rows.Count).End(3).row - 1 To 1 Step -1
    x = .Cells(i + 1, "A").Value
        If .Cells(i + 1, "A") <> .Cells(i, "A") Then
            Workbooks.Add
            ActiveWorkbook.SaveAs "C:\Users\aman\Desktop\visual\Learning process\" & x & ".xlsx"
            ActiveSheet.Name = x
            Rows(1).Value = .Rows(1).Value
            .Range("A1:A" & .Range("A" & Rows.Count).End(3).row).AutoFilter 1, .Cells(i + 1, "A")
            .Range("A2:D" & .Range("A" & Rows.Count).End(3).row).SpecialCells(12).Copy Range("A" & Rows.Count).End(3)(2)
            .Cells.Copy
            Range("A1").PasteSpecial xlPasteFormats
            ActiveSheet.Cells.Columns.AutoFit
            'ActiveWorkbook.Close True
        End If
        .Activate
    Next i
End With
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = xlCalculationManual
End With
End Sub

 

[aman2059]

It worked as I wanted. thank you once again.