How to create new workbook by copying rows from multiple sheets based on value in column A
Category: [Excel] Demo Available
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.
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.
See also: Index to Excel VBA Code and Index to Excel Freebies and Lesson 1 - Excel Fundamentals and Index to how to… providing a range of solutions and Index to new resources and reference sheets
See also:
| How to use a Macro to copy rows from multiple worksheets based on a cell value greater than zero |
| How to read only open an excel workbook (multiple users simultaneously) |
| How to extract multiple emails separated with semicolon and brackets |
| How to use IF formula with multiple criteria |
Click here to visit our Free 24/7 Excel/VBA Help Forum where there are thousands of posts you can get information from, or you can join the Forum and post your own questions.