excel vba copy rows and columns based on criteria

[mckechnie1020]

Hi,

Hoping someone can help me with this, have search the forums but cant adapt any of the code successfully

I have an excel sheet with a few thousand lines of data on it for invoice remittances. In column A is a unique company name with blank cells below it until it reaches the next company name and from Col B to G is various data. Im trying to find some code which will copy all the rows and columns into a new workbook each time the unique company name changes i.e. A1: G50 and then A51:G65. So I will then have a hundred separate workbooks and each book will be named after the unique company name and wont lose the format of the data.

Thank you in advance.

 

[Meggesto]

Sub McKenhnie()

Dim LastRowB As Long
Dim LastRowA As Long
Dim EndRow As Long
Dim StartRow As Long
Dim CompanyName As String

LastRowB = Range("B" & Rows.Count).End(xlUp).Row
LastRowA = Range("A" & Rows.Count).End(xlUp).Row
EndRow = 2

Do While LastRowA >= EndRow
    StartRow = Range("A" & EndRow, "A" & LastRowB).SpecialCells(xlCellTypeConstants).Cells.Row
        If EndRow < LastRowA Then
            EndRow = Range("A" & EndRow + 1, "A" & LastRowB).SpecialCells(xlCellTypeConstants).Cells.Row
        ElseIf EndRow = LastRowA Then
            EndRow = LastRowB
        End If
        
        ActiveWorkbook.Sheets.Add After:=ActiveSheet
        CompanyName = Cells(StartRow, 1).Value
        ActiveSheet.Name = CompanyName
                ActiveSheet.Range("A2").Value = CompanyName
                ActiveSheet.Range("A1").EntireRow.Value = Sheet1.Range("A1").EntireRow.Value
                If EndRow < LastRowB Then
                    Sheets(CompanyName).Range("A" & 2, "A" & EndRow - StartRow + 1).EntireRow.Value = Range("A" & StartRow, "A" & EndRow).EntireRow.Value
                ElseIf EndRow = LastRowB Then
                    Sheets(CompanyName).Range("A" & 2, "A" & EndRow - StartRow + 2).EntireRow.Value = Range("A" & StartRow, "A" & EndRow).EntireRow.Value
                End If
        Loop
End Sub

This should do what you're looking for. It assumes you have a header Row in Row 1 and your companies begin on Row 2.