Excel VBA copy data from one sheet to another based on cell value

Author: Oscar Cronquist Article last updated on May 30, 2022

This article demonstrates a macro that inserts new worksheets based on names in a cell range. The cell range may have multiple columns if you like.

This macro allows you to create new worksheets very quickly.

Table of Contents

The animated image above shows how this macro works.

1. Press Alt + F8 to open the Macro dialog box.
2. Select macro CreateSheets.
3. Press with mouse on "Run" button.
4. An input box appears asking for a cell range.
5. Select a cell range and press with left mouse button on the "OK" button.
6. Worksheets are now added automatically to the workbook and named correspondingly after the values in the cell range.

Back to top

1.2 VBA macro

'Name macro Sub CreateSheets() 'Dimension variables and declare data types Dim rng As Range Dim cell As Range 'Enable error handling On Error GoTo Errorhandling 'Show inputbox to user and prompt for a cell range Set rng = Application.InputBox(Prompt:="Select cell range:", _ Title:="Create sheets", _ Default:=Selection.Address, Type:=8) 'Iterate through cells in selected cell range For Each cell In rng 'Check if cell is not empty If cell <> "" Then 'Insert worksheet and name the worksheet based on cell value Sheets.Add.Name = cell End If 'Continue with next cell in cell range Next cell 'Go here if an error occurs Errorhandling: 'Stop macro End Sub

Back to top

1.3 Where to put the code

1. Copy above VBA code.
2. Press Alt + F11 to open the Visual Basic Editor.
3. Press with mouse on your workbook in the Project Explorer.
4. Press with mouse on "Insert" on the menu.
5. Press with mouse on "Module".
6. Paste VBA code to code window, see image above.

Back to top

1.4 Explaining code

Creating procedures in excel is easy. Open the Visual Basic Editor using one of these instructions:

• Press Alt+F11
• Go to tab Developer and press with left mouse button on Visual basic "button"

You create macro procedures in a module. First create a module. Press with right mouse button on on your workbook in the project explorer. Press with left mouse button on Insert | Module.

Sub CreateSheets()

Type: Sub CreateSheets() in the module. CreateSheets() is the name of the macro.

Dim rng As Range
Dim cell As Range 

These lines declare rng and cell as range objects.  A range object can contain a single cell, multiple cells, a column or a row. Read more about declaring variables.

On Error Goto Errorhandling

If the user selects something else than a cell range like a chart, this line makes the procedure go to Errorhandling.

Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, Type:=8)

The inputbox asks the user for a cell range. The cell range is stored in the range object rng.

For Each cell In rng

This stores each cell value from the range object rng to the cell object, one by one.

If cell <> "" Then

Checks if the cell variable is NOT empty. If the cell variable is empty the procedure goes to "End If" line. We can't create a sheet with no name.

Sheets.Add.Name = cell

Creates a new sheet named with the value stored in the cell variable.

End If

The end of the If statement.

Next cell

Go back to the "For each" statement and store a new single cell in the cell object.

Errorhandling:

The procedure goes to this line if a line returns an error.

End Sub

All procedures must end with this line.

Back to top

1.5 Excel file

Back to top

Recommended reading

List all open workbooks and corresponding sheets (vba)

2. Create new worksheets programmatically based on a comma-delimited list

The image above shows a comma delimited list in cell B2, the macro below in section 2.1 lets you select a cell containing a comma delimiting list.

It splits the string based on the comma into an array of values. The values are then used to insert new worksheets with names based on those array values.

Back to top

2.1 VBA code

Sub CreateSheetsFromList() Dim rng As Range Dim cell As Range Dim Arr As Variant On Error GoTo Errorhandling Set rng = Application.InputBox(Prompt:="Select cell:", _ Title:="Create sheets", _ Default:=Selection.Address, Type:=8) Arr = Split(rng.Value, ", ") For Each Value In Arr If Value <> "" Then Sheets.Add.Name = Value End If Next Value Errorhandling: End Sub

Back to top

Where to put the code?

2.2 Excel file

Back to top

3. Create new worksheets using an Input box

The following macro displays an input box allowing the Excel user to type a worksheet name, the worksheet is created when the "OK" button is pressed.

The macro stops if nothing is typed or the user presses the "Cancel" button. It shows a new input box each time a new worksheet is created.

3.1 VBA code

Sub CreateSheetsFromDialogBox() Dim str As String Dim cell As Range Dim Arr As Variant On Error GoTo Errorhandling Do str = Application.InputBox(Prompt:="Type worksheet name:", _ Title:="Create sheets", Type:=3) If str = "" Or str = "False" Then GoTo Errorhandling: Else Sheets.Add.Name = str End If Loop Until str = "False" Errorhandling: End Sub

Where to put the code?

3.2 Excel file

I modified user3598756's answer above to bypass restrictions on the max length allowed for the name of a sheet. It will concatenate the first and last 13 characters of the name with 4 dots in between

Option Explicit Sub CopyRows() Dim rngCell As Range Dim depSheet As Worksheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Worksheets("DATA") '<--|refer to data sheet .Rows(1).Insert '<--|insert a temporary header row: it'll be used for AutoFilter() method and eventually deleted .Cells(1, 1).Value = "Table_Name" '<--| place a dummy header in the temporary header row With .Range("A1", .Cells(.Rows.count, 1).End(xlUp)).Offset(, .UsedRange.Columns.count) '<--| refer to a "helper" column out of the used range and limited to column "A" last non empty row .Value = .Offset(, -.Parent.UsedRange.Columns.count).Value '<--| duplicate departments (column "A") values in helper one .RemoveDuplicates Columns:=Array(1), Header:=xlYes '<--| leave only departments unique values in "helper" column For Each rngCell In .Range("A2:A" & .Cells(.Rows.count, 1).End(xlUp).Row) '<--|loop through "helper" column departments unique values Set depSheet = GetSheet(.Parent.Parent, rngCell.Value) '<--|get or add the worksheet corresponding to current department With .Offset(, -.Parent.UsedRange.Columns.count + 1) '<--|refer to departments column .AutoFilter field:=1, Criteria1:=rngCell.Value '<--| filter it on current department value With .Offset(1).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible) '<--| refer to department filtered cells depSheet.Cells(depSheet.Rows.count, 1).End(xlUp).Offset(1).Resize(.Cells.count, 3).Value = .Resize(, 3).Value '<--|copy their values along with columns "B" and "C" ones into first empty row of the corresponding worksheet End With End With Next rngCell .ClearContents '<--| clear "helper" column End With .AutoFilterMode = False .Rows(1).Delete '<--| delete temporary header row End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub Function GetSheet(wb As Workbook, shtName As String) As Worksheet On Error Resume Next Set GetSheet = wb.Worksheets(shtName) '<--| try and set a sheet with passed name On Error GoTo 0 If GetSheet Is Nothing Then '<--| if there weas no such sheet... Dim count As Long count = Len(shtName) Dim newName As String If count > 30 Then newName = Left(shtName, 13) & "...." & Right(shtName, 13) Else newName = shtName End If Set GetSheet = wb.Worksheets.Add(After:=ActiveSheet) '<--|... add a new sheet With GetSheet .Name = newName '<--|rename it after passed name .Range("A1:C1").Value = Array("DEPARTMENT", "EMPCODE", "EMPNAME") '<--| add headers End With End If End Function