How to Create new workbook by copying rows from multiple sheets based on value in column A

How to create new workbook by copying rows from multiple sheets based on value in column A

Requirement:

The user wants to create a workbook by copying rows from multiple sheets based on values found in column A. Example: Copy all rows on sheet 1 were "Value 2" is found in column A and create a new workbook with the same sheet name and paste the copied row data.

Do this for each sheet in the workbook where value 2 is found in column A. So the desired outcome would be a new workbook named "Value 2" with the same sheet names as the original workbook with only "Value 2" data in each sheet.

The user has attached two example workbooks. One as the original workbook and the second is the desired outcome.

https://www.ozgrid.com/forum/forum/help-forums/excel-vba-macros/148799-create-new-workbook-by-copying-rows-from-multiple-sheets-based-on-value-in-column-a

Solution:

Note that KjBox has changed the sheet names, they cannot be named "Sheet1", Sheet2" and so on because at least "Sheet1" will exist in the new workbook when it is first added.

The code in a standard module is

Code:

Sub CreateNewWorkbook()
    Dim x, y(), i As Long, ii As Long, ws As Worksheet, wbk As Workbook
    
    Const sValue As String = "VALUE 2" '// Change this to actual value to be used
    
    Application.ScreenUpdating = 0
    Set wbk = Workbooks.Add
    ThisWorkbook.Activate
    For Each ws In Sheets
        ii = 1
        x = ws.Cells(1).CurrentRegion
        ReDim Preserve y(1 To UBound(x, 2), 1 To 1)
        For i = 1 To UBound(x, 2)
            y(i, 1) = x(1, i)
        Next
        For i = 2 To UBound(x, 1)
            If x(i, 1) = sValue Then
                ii = ii + 1: ReDim Preserve y(1 To UBound(x, 2), 1 To ii)
                For iii = 1 To UBound(x, 2)
                    y(iii, ii) = x(i, iii)
                Next
            End If
        Next
        With wbk
            .Sheets.Add , .Sheets(.Sheets.Count)
            With .Sheets(.Sheets.Count)
                .Name = ws.Name
                .[a1].Resize(UBound(y, 2), UBound(y, 1)) = Application.Transpose(y)
                With .Cells(1).CurrentRegion.Rows(1)
                    .Font.Bold = 1
                    .HorizontalAlignment = xlCenter
                End With
            End With
        End With
        Erase y
    Next
    With wbk
        Application.DisplayAlerts = 0
        For i = .Sheets.Count To 1 Step -1
            If .Sheets(i).Name Like "Sheet*" Then .Sheets(i).Delete
        Next
        Application.DisplayAlerts = 1
        .SaveAs sValue, 51
    End With
                
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by KjBox.