Sub CreateNameNewSheets() Dim LR As Long Dim c As Range Dim ws As Worksheet LR = Range("A" & Rows.Count).End(xlUp).Row For Each c In Range("A2:A" & LR) Set ws = Nothing On Error Resume Next Set ws = Worksheets(c.Value) If ws Is Nothing Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value End If Next c End Sub
"Hope I clarified and expect the right solution."
Option Explicit Sub CreateSheetsCopyData() Dim ar As Variant Dim i As Integer Dim LR As Long Dim c As Range Dim ws As Worksheet, ws1 As Worksheet Set ws1 = Worksheets("Data Input") LR = ws1.Range("B" & Rows.Count).End(xlUp).Row ar = ws1.Range("B6", ws1.Range("B" & ws1.Rows.Count).End(xlUp)) Application.ScreenUpdating = False For Each c In ws1.Range("B6:B" & LR) Set ws = Nothing On Error Resume Next Set ws = Worksheets(c.Value) If ws Is Nothing Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value End If Next c For i = 0 To UBound(ar) Sheets(ar(i, 1)).UsedRange.ClearContents ws1.Range("B5", ws1.Range("B" & ws1.Rows.Count).End(xlUp)).AutoFilter 1, ar(i, 1) ws1.[A5].CurrentRegion.Copy Sheets(ar(i, 1)).Range("A" & Rows.Count).End(xlUp) Sheets(ar(i, 1)).Columns.AutoFit Next i ws1.[B5].AutoFilter ws1.Select Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Sheets created/Data transfer completed!", vbExclamation, "Status" End Sub
Option Explicit Sub CreateSheetsTransferData() Dim ar As Variant Dim i As Integer Dim lr As Long Dim ws As Worksheet Dim sh As Worksheet Application.ScreenUpdating = False lr = Range("A" & Rows.Count).End(xlUp).Row ar = Sheet1.Range("I3", Sheet1.Range("I" & Sheet1.Rows.Count).End(xlUp)) Set sh = Sheet1 For i = LBound(ar) To UBound(ar) If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1) End If Set ws = Worksheets(CStr(ar(i, 1))) sh.Range("I2:I" & lr).AutoFilter 1, ar(i, 1) sh.Range("A1", sh.Range("H" & sh.Rows.Count).End(xlUp)).Copy ws.[A1] ws.Columns.AutoFit Next i sh.[I2].AutoFilter Application.CutCopyMode = False Application.ScreenUpdating = True sh.Select MsgBox "Sheets created/data transfer completed!", vbExclamation, "STATUS" End Sub
Sub TransferData() Dim i As Integer Application.ScreenUpdating = False Sheet2.Columns.AutoFit For i = 2 To 96 '-----> Your data set appears to be set at 96 rows. If Left(Cells(i, 8), 3) = "RMA" And Cells(i, 9) = 541466 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet3.Range("A" & Rows.Count).End(3)(2) Sheet3.Columns.AutoFit ElseIf Left(Cells(i, 8), 3) <> "RMA" And Cells(i, 9) = 541466 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet4.Range("A" & Rows.Count).End(3)(2) Sheet4.Columns.AutoFit ElseIf Left(Cells(i, 8), 3) <> "RMA" And Cells(i, 9) = 532455 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet5.Range("A" & Rows.Count).End(3)(2) Sheet5.Columns.AutoFit ElseIf Left(Cells(i, 8), 3) = "RMA" And Cells(i, 9) = 532455 Then Range(Cells(i, 1), Cells(i, 17)).Copy Sheet6.Range("A" & Rows.Count).End(3)(2) Sheet6.Columns.AutoFit End If Next Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
but in one sheet there will be like maximum 4 customers..so that would be 8 new sheets.
Sub TransferData() Application.ScreenUpdating = False Dim LR As Long Dim MySheet As String Dim cell As Range Dim c As Range Dim ws As Worksheet Sheet2.Range("T2:T96").Formula = "=IF(LEFT(H2,3)=""RMA"",""RMA"",""Non-RMA"")&I2" LR = Sheet2.Range("T" & Rows.Count).End(xlUp).Row For Each c In Sheet2.Range("T2:T" & LR) Set ws = Nothing On Error Resume Next Set ws = Worksheets(c.Value) If ws Is Nothing Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = c.Value End If Next c Worksheets.FillAcrossSheets Sheet2.[A1:Q1] For Each cell In Sheet2.Range("T2:T" & LR) MySheet = cell.Value cell.EntireRow.Copy Sheets(MySheet).Range("A" & Rows.Count).End(3)(2) Sheets(MySheet).Columns.AutoFit Next cell Sheet2.Range("T2:T96").ClearContents MsgBox "Data transfer completed." Application.CutCopyMode = False Application.ScreenUpdating = True Sheet2.Select End Sub
Sub CreateSheetsTransferData() Dim ar As Variant Dim i As Integer Dim lr As Long Dim ws As Worksheet Dim sh As Worksheet Application.ScreenUpdating = False Sheet2.Range("T2:T96").Formula = "=IF(LEFT(H2,3)=""RMA"",""RMA"",""Non-RMA"")&I2" lr = Range("A" & Rows.Count).End(xlUp).Row ar = Sheet2.Range("T2", Sheet2.Range("T" & Sheet2.Rows.Count).End(xlUp)) Set sh = Sheet2 For i = LBound(ar) To UBound(ar) If Not Evaluate("ISREF('" & ar(i, 1) & "'!A1)") Then Worksheets.Add(After:=Sheets(Sheets.Count)).Name = ar(i, 1) End If Set ws = Worksheets(CStr(ar(i, 1))) sh.Range("T1:T" & lr).AutoFilter 1, ar(i, 1) sh.[A1].CurrentRegion.Copy ws.[A8] ws.Columns.AutoFit Next i sh.[T1].AutoFilter sh.Columns(20).ClearContents Application.CutCopyMode = False Application.ScreenUpdating = True sh.Select MsgBox "All done!", vbExclamation, "STATUS" End Sub
Sheet2.Range("T2:T96").Formula = "=IF(LEFT(H2,3)=""RMA"",""RMA"",""Non-RMA"")&I2"
lr1 = Sheet2.Range("Q" & Rows.Count).End(xlUp).Row Sheet2.Range("T2:T" & lr1).Formula = "=IF(LEFT(H2,3)=""RMA"",""RMA"",""Non-RMA"")&I2"
Dim lr1 As Long
Thanks for immediate reply. The code works good and creates new worksheets listed in "Summary".
Please refer to my file (shared as link http://speedy.sh/xcHkc/Macro-Temp.xlsm ) there are two sheets"Summary" consists of list and "Sheet1" having data.
The existing "Sheet1" (with data) to be renamed and copied along with data for the list in "Summary" (like, 10, 20, 30, 40.... 200)
Hope I clarified and expect the right solution.