merge multiple worksheets into one - excel

I'm trying to merge multiple worksheets into one summary sheet.
Each Worksheet has the name 'Table #number', for example Table 1, Table 2 etc. The layout of each sheet is identical. Data range is columns A1 : N13.
This function doesn't work: =SUM('Table 1':'Table 25'!$A$1:$N$13).
How do I use VBA to amalgamate this data?

Sub MergeSheet()
'Declaring the Variables
Dim LastRow, ShtCnt As Integer
Dim ShtName As String
Dim NewSht As Worksheet
'Assinging a Sheet Name by UserInput
ShtName:
ShtName = InputBox("Enter the Sheet Name you want to create", "Merge Sheet", "Master Sheet")
'Count of Total Worksheet in the present workbook
ShtCnt = Sheets.Count
'Using For Loop check if the worksheet exists
For i = 1 To ShtCnt
If Sheets(i).Name = ShtName Then
MsgBox "Sheet already Exists", , "Merge Sheet"
GoTo ShtName
End If
Next i
'Create a New Sheet
Worksheets.Add.Name = ShtName
'Assigning NewSht as Current Sheet
Set NewSht = ActiveSheet
'Moving Worksheet to the beginning of this workbook
NewSht.Move before:=Worksheets(1)
'Copying all the data to the New Sheet Using For Loop
For i = 2 To ShtCnt + 1
'If i=2 Then copy all the data from the second sheet including header.
If i = 2 Then
Sheets(i).UsedRange.Copy NewSht.Cells(1, 1)
Else
'If i is grater than 2 then copy all the data excluding Header(1st Row).
Sheets(i).UsedRange.Offset(1, 0).Resize(Sheets(i).UsedRange.Rows.Count - 1, Sheets(i).UsedRange.Columns.Count).Copy NewSht.Cells(LastRow + 1, 1)
End If
LastRow = NewSht.Cells.SpecialCells(xlCellTypeLastCell).Row
Next i
'Displaying the Message after copying data successfully
MsgBox "Data has been copied to " & ShtName, , "Merge Sheet"
End Sub

This is a simplified example:
Option Explicit
Sub amalgamateData()
'initialise result variable
Dim myResult As Double
myResult = 0
'loop through sheets to get the sum
Dim wks As Excel.Worksheet 'loop control variable
For Each wks In Excel.ThisWorkbook.Worksheets
If Left(wks.Name, 5) = "Table" Then ' only the "Table" sheets
With wks
Dim rngTarget As Range
myResult = myResult + Excel.Application.WorksheetFunction.Sum(.Range("A1:N13"))
End With
End If
Next
'add result to sheet "Result"
Excel.ThisWorkbook.Sheets("Result").Range("A1") = myResult
End Sub
My starting point was this SO Post: how-to-merge-data-from-multiple-sheets
As Siddharth saud - there loads of references for you on SO HERE IS A SEARCH FOR YOU ... CHECK OUT WHAT IS IN THE BOX IN THE TOP RIGHT OF THE SCREEN

Related

Pasting specific data on a new sheet with macro

I have a hospital spreadsheet with data, where the data is organised depending on age, sex, Health Authority etc. Like this:
Where "sha" means the Health Authority, and each number corresponds to a certain one.
1-Norfolk, Suffolk and Cambridgeshire
2-Bedforshire & Hertfordshire
and so on until Health Authority number 28
I am creating a macro that opens a new sheet, and I need to only paste the data of the patients from a certain Health authority previously selected from a drop-down box.
I have already created the macro that creates the new sheet (i'll paste the code here), but now I need to paste all the data of the patients only if they belong to the health authority selected from the drop-down box.
This is my code so far:
Option Explicit
Sub createsheet()
Dim sName As String, ws As Worksheet
sName = Sheets("user").Range("M42").Value
' check if already exists
On Error Resume Next
Set ws = Sheets(sName)
On Error GoTo 0
If ws Is Nothing Then
' ok add
Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
ws.Name = sName
MsgBox "Sheet created : " & ws.Name, vbInformation
Else
' exists
MsgBox "Sheet '" & sName & "' already exists", vbCritical, "Error"
End If
End Sub
You can call this sub from your sub like:
Transfer_to_NewSheet ws, SHA
Where SHA is the SHA number from whatever drop down you're using.
I'm sure you can figure out how to do that.
Also remember to change:
Set Master = Worksheets("Main")
to whatever your data sheet is called.
Sub Transfer_to_NewSheet(WS As Worksheet, SHA)
Dim Master As Worksheet
Dim DataRG As Range
Dim InArray
Dim OutArray
Dim I As Long
Dim Y As Long
Dim X As Long
Dim W As Long
Dim lRow As Long
Dim lCol As Long
Dim SHAcol As Long
' Or whatever your master sheet is called
Set Master = Worksheets("Main")
With Master
lCol = .Range("ZZ1").End(xlToLeft).Column
lRow = .Range("A" & Rows.Count).End(xlUp).Row
SHAcol = .Range("A1").Resize(1, lCol).Find(What:="sha", LookIn:=xlValues, LookAt:=xlWhole).Column
Set DataRG = .Range("A1").Resize(lRow, lCol)
End With
InArray = DataRG
ReDim OutArray(1 To lRow, 1 To lCol)
Y = 1
For I = 1 To UBound(InArray, 1)
If InArray(I, SHAcol) = SHA Or I = 1 Then
For X = 1 To UBound(InArray, 2)
OutArray(Y, X) = InArray(I, X)
Next X
Y = Y + 1
End If
Next I
WS.Range("A1").Resize(lRow, lCol) = OutArray
End Sub
This is the Data I used to test:
This is the output I get from SHA = 12
And this is the sub I was using to call it, just for reference. don't use it.
Sub CallWSxfer()
Dim SHA As Long
' Or pull it from whatever drop down you're using...
SHA = InputBox("Enter SHA Number:", "SHA to New Sheet", "01")
Transfer_to_NewSheet Sheet4, SHA
End Sub
you can use AutoFilter() method of Range object:
assuming:
data have headers in row 10 from column 1 rightwards and don't have blank rows/columns in between
the searched SHA will always be found in data column F
you could place this snippet right after your MsgBox "Sheet created : " & ws.Name, vbInformation code line
With Sheets("data")
With .Range("A10").CurrentRegion
.AutoFilter field:=6, Criteria1:=sName
.SpecialCells(XlCellType.xlCellTypeVisible).Copy ws.Range("A1")
End With
.AutoFilterMode = False
End With

Copy a Worksheet if the Cell Value equals a certain string using row and column indexes

The purpose of this is to find the column who has the header "Type Test" and loop through that column, in this case B to find all unique value cells. If the string in column B is unique and does not replace, I need it to make a copy of the worksheet whose name matches the trial name in column A. So for Test 1 who has a row index of 3 and a column index of 2, will make a copy of the worksheet in the current workbook called "DEF" and rename the copy to be "Test 1"
For example here is my data
A B
Trial Type_Test
DEF Test 1
ABC Test 3
ABC Test 10
DEF Test 14
ABC Test 10
However, I dont want to make a copy of the sheet ABC if the column B values repeat for column A, so since rows 3 and 5 are the same, I only want to make copies of ABC sheet twice, once for row 2 and once for row 3. Row 5 can be ignored since it is the same as row 3.
I have written a code that does the first part regarding make a sheet and renaming it, I just cant get the copy the other worksheet part.
Public Sub Main()
Dim srtsht As Variant, sysnum As Variant, arr As Variant, partnum As Variant
Dim wsh As Worksheet
srtsht = Sheets("Sheet1").Range("E2:E15")
With CreateObject("scripting.dictionary") ' store data in array where each item is associated with a unique key
For Each sysnum In srtsht
arr = .Item(sysnum)
Next sysnum
For Each value In .Keys
On Error Resume Next
If value <> "" Then
Set wsh = Nothing ' clear the variable wsh
Set wsh = Worksheets(CStr(value)) ' try to set wsh to the sheet with Value as name
On Error GoTo 0
If wsh Is Nothing Then
Call position
If Worksheets("Sheet1").Cells(A_row,A_col).Value = "ABC" Then
Worksheets("ABC").Copy After:=ActiveSheet
wsh = Worksheets("Sheet1").Cells(A_row,A_col).Values
Worksheets("ABC (2)").name = wsh
wsh.name = CStr(Value)
End If
Else
MsgBox "Sheet" & Values & "already exists.", vbInformation
End If
End If
Next Value
End With
End Sub
Sub position ()
Dim syswaivernum As Range, partnumber As Range
For Each syswaivernum In Worksheets("Sheet1").Range("A1:Z20")
If syswaivernum.value = "Number(s)" Then
sysnumcol = syswaivernum.Column
sysnumrow = syswaivernum.Row
End If
Next syswaivernum
For Each partnumber In Worksheets("Sheet1").Range("A1:Z20")
If partnumber.value = "Part" Then
A_col = partnumber.Column
A_row = partnumber.Row
End If
Next partnumber
End Sub
Try this - see comments inline:
Public Sub Main()
Dim wb As Workbook, tst As String, wsName As String
Dim c As Range, ws As Worksheet, dict As Object
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
Set dict = CreateObject("scripting.dictionary")
For Each c In ws.Range("E2:E15").Cells
tst = c.Value
If Not dict.exists(tst) Then 'first time seeing this value?
dict.Add tst, True '###
If Not SheetExists(tst) Then
wsName = c.EntireRow.Columns("A").Value 'sheet to be copied
If SheetExists(wsName) Then 'if there's a sheet for wsName
wb.Worksheets(wsName).Copy After:=ws 'copy the sheet
wb.Worksheets(ws.Index + 1).Name = tst '### rename the copy
End If
Else
MsgBox "Sheet '" & wsName & "' already exists"
End If
End If
Next c
End Sub
'Does a sheet named `SheetName` exist?
' Defaults to checking `ThisWorkbook` if `wb` is not specified
Function SheetExists(SheetName As String, _
Optional wb As Excel.Workbook) As Boolean
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
SheetExists = Not wb.Sheets(SheetName) Is Nothing
End Function

Excel file crashes and closes when I run the code, but results of the code who when I reopen the file

I am copying data under columns with matching headers between the source sheet and the destination sheet. Both the sheets are in the same excel file but they need to have a clarification number.
For example, one of the columns in the destination sheet has the the clarification number QM6754 and the row of data of QM6754. The source sheet also has the clarification number column but I dont want to copy it, I want to copy the other data in the row of this specific clarification number to the destination sheet that in one of its columns. this way the data isn't copied randomly and the entire row from each sheet relate to each other.
The code I used shows results(I modified it) but when I run it, the excel file shows (not responding) for about 3-4 minutes and then shutsdown or leaves a blank Excel sheet and VBA window. I close the excel file and reopen it and the data has been copied. The file is quite large and I have three pushbuttons that run this code for each sheet I want to copy data from. Three sheets with average of 3k-6k rows. But I cannot eliminate the rows.
The code runs but I would like to optimize of the way it runs because it isn't practical to run, close file and then open file again. Could the issue be with the For loop?
Sub CopyColumnData()
Dim wb As Workbook
Dim myworksheet As Variant
Dim workbookname As String
' DECLARE VARIABLES
Dim i As Integer ' Counter
Dim j As Integer ' Counter
Dim colsSrc As Integer ' PR Report: Source worksheet columns
Dim colsDest As Integer ' Open PR Data: Destination worksheet columns
Dim rowsSrc As Long ' Source worksheet rows
Dim WsSrc As Worksheet ' Source worksheet
Dim WsDest As Worksheet ' Destination worksheet
Dim ws1PRRow As Long, ws1EndRow As Long, ws2PRRow As Long, ws2EndRow As Long
Dim searchKey As String, foundKey As String
workbookname = ActiveWorkbook.Name
Set wb = ThisWorkbook
myworksheet = "Sheet 1 copied Data"
wb.Worksheets(myworksheet).Activate
' SET VARIABLES
' Source worksheet: Previous Report
Set WsSrc = wb.Worksheets(myworksheet)
Workbooks(workbookname).Sheets("Main Sheet").Activate
' Destination worksheet: Master Sheet
Set WsDest = Workbooks(workbookname).Sheets("Main Sheet")
'Adjust incase of change in column in both sheets
ws1ORNum = "K" 'Clarification Number
ws2ORNum = "K" 'Clarification Number
' Setting first and last row for the columns in both sheets
ws1PRRow = 3 'The row we want to start processing first
ws1EndRow = WsSrc.UsedRange.Rows(WsSrc.UsedRange.Rows.Count).Row
ws2PRRow = 3 'The row we want to start search first
ws2EndRow = WsDest.UsedRange.Rows(WsDest.UsedRange.Rows.Count).Row
For i = ws1PRRow To ws1EndRow ' first and last row
searchKey = WsSrc.Range(ws1ORNum & i)
'if we have a non blank search term then iterate through possible matches
If (searchKey <> "") Then
For j = ws2PRRow To ws2EndRow ' first and last row
foundKey = WsDest.Range(ws2ORNum & j)
' Copy result if there is a match between PR number and line in both sheets
If (searchKey = foundKey) Then
' Copying data where the rows match
WsDest.Range("AI" & j).Value = WsSrc.Range("A" & i).Value
WsDest.Range("AJ" & j).Value = WsSrc.Range("B" & i).Value
WsDest.Range("AK" & j).Value = WsSrc.Range("C" & i).Value
WsDest.Range("AL" & j).Value = WsSrc.Range("D" & i).Value
WsDest.Range("AM" & j).Value = WsSrc.Range("E" & i).Value
WsDest.Range("AN" & j).Value = WsSrc.Range("F" & i).Value
WsDest.Range("AO" & j).Value = WsSrc.Range("G" & i).Value
WsDest.Range("AP" & j).Value = WsSrc.Range("H" & i).Value
Exit For
End If
Next
End If
Next
'Close Initial PR Report file
wb.Save
wb.Close
'Pushbuttons are placed in Summary sheet
'position to Instruction worksheet
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
ActiveWorkbook.Worksheets("Summary").Select
ActiveWindow.ScrollColumn = 1
Range("A1").Select
End Sub
To increase the speed and reliability, you will want to handle the copy/paste via array transfer instead of the Range.Copy method. Given your existing code, here's how a solution that should work for you:
Sub CopyColumnData()
'Source data info
Const sSrcSheet As String = "Sheet 1 copied Data"
Const sSrcClarCol As String = "K"
Const lSrcPRRow As Long = 3
'Destination data info
Const sDstSheet As String = "Main Sheet"
Const sDstClarCol As String = "K"
Const lDstPRRow As Long = 3
'Set variables based on source and destination
On Error Resume Next
Dim wbSrc As Workbook: Set wbSrc = ThisWorkbook
Dim wsSrc As Worksheet: Set wsSrc = wbSrc.Worksheets(sSrcSheet)
Dim wbDst As Workbook: Set wbDst = ActiveWorkbook
Dim wsDst As Worksheet: Set wsDst = wbDst.Worksheets(sDstSheet)
On Error GoTo 0
'Verify source and destination were found
If wsSrc Is Nothing Then
MsgBox "Worksheet """ & sSrcSheet & """ not found in " & wbSrc.Name
Exit Sub
End If
If wsDst Is Nothing Then
MsgBox "Worksheet """ & sDstSheet & """ not found in " & wbDst.Name
Exit Sub
End If
'Setup variables to handle Clarification Number matching and data transfer via array
Dim hDstClarNums As Object: Set hDstClarNums = CreateObject("Scripting.Dictionary") 'Clarification Number Matching
'Load Source data into array
Dim rSrcData As Range: Set rSrcData = wsSrc.Range(sSrcClarCol & lSrcPRRow, wsSrc.Cells(wsSrc.Rows.Count, sSrcClarCol).End(xlUp))
Dim aSrcClarNums() As Variant: aSrcClarNums = rSrcData.Value
Dim aSrcData() As Variant: aSrcData = Intersect(rSrcData.EntireRow, wsSrc.Columns("A:H")).Value 'Transfer data from columns A:H
'Prepare dest data array
Dim rDstData As Range: Set rDstData = wsDst.Range(sDstClarCol & lDstPRRow, wsDst.Cells(wsDst.Rows.Count, sDstClarCol).End(xlUp))
Dim aDstClarNums() As Variant: aDstClarNums = rDstData.Value
Dim aDstData() As Variant: aDstData = Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value 'Destination will be into columns AI:AP
'Use dictionary to perform Clarification Number matching
Dim vClarNum As Variant
For Each vClarNum In aDstClarNums
If Not hDstClarNums.Exists(vClarNum) Then hDstClarNums.Add vClarNum, hDstClarNums.Count + 1
Next vClarNum
'Transfer data from source to destination using arrays
Dim i As Long, j As Long
For i = 1 To UBound(aSrcClarNums, 1)
For j = 1 To UBound(aSrcData, 2)
If hDstClarNums.Exists(aSrcClarNums(i, 1)) Then aDstData(hDstClarNums(aSrcClarNums(i, 1)), j) = aSrcData(i, j)
Next j
Next i
'Output to destination
Intersect(rDstData.EntireRow, wsDst.Columns("AI:AP")).Value = aDstData
'Save and close source workbook (uncomment next line if this is necessary)
'wbSrc.Close SaveChanges:=True
'Activate summary sheet, cell A1 in destination workbook (uncomment these lines if this is necessary)
'wbDst.Worksheets("Summary").Activate
'wbDst.Worksheets("Summary").Range("A1").Select
End Sub

How to copy row from Excel sheet and paste it in another workbook in a specific row

In Workbook 1, I have a spreadsheet that tracks the inventory of meat products.
Row 1 is used for the column names: "Parcel Tracking Number" in column A and other data related to the parcel in the other columns (Such as "Date of export", "Weight" and "Content" among other things).
Column I describes the parcel's "Content" and these parcels all contain "Meat".
The rows of information in this spreadsheet have been copied from Workbook 2 which contains parcels that contain "Meat", "Cheese", "Milk" and "Eggs" in column I.
Both workbooks have the same columns names in row 1.
In workbook 1, I update the data on some of the rows and I want the change to be applied in Workbook 2 by copying workbook 1 rows and pasting them in Workbook 2 in the rows where the "Parcel Tracking Number" in column A matches.
So far, I have the code to copy all the "Meat" parcel rows from Workbook 2 and paste them in Workbook 1 but now I need help with this new situation.
The program is executed by opening Workbook 2 and pressing a command button which opens workbook 1 and starts copying the rows to the Meat worksheet.
Here it is:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False ' Screen Update application turned off in order to make program run faster
Dim y As Workbook '
Dim sh As Worksheet '
Set y = Workbooks.Open("\\SCF1\USERS-D\Robert\My Documents\Excel VBA code\Meat.xlsx") '
a = ThisWorkbook.Worksheets("Products").Cells(Rows.Count, 1).End(xlUp).Row
Set sh = Workbooks("Meat.xlsx").Worksheets("Meat")
With ThisWorkbook.Worksheets("Products")
For i = 2 To a ' value ''i'' is the column number
If ThisWorkbook.Worksheets("Products").Cells(i, 9).Value Like "*Meat*" And IsError(Application.Match(.Cells(i, "A").Value, sh.Columns("A"), 0)) Then ' this sets the condition for which the data can only be copied if the row has '' Meat '' included in the 9th column (substance) and if the row is not already copied in the Meat worksheet.
ThisWorkbook.Worksheets("Products ").Rows(i).Copy
Workbooks("Meat.xlsx").Worksheets("Meat").Activate
b = Workbooks("Meat.xlsx").Worksheets("Meat ").Cells(Rows.Count, 1).End(xlUp).Row
Workbooks("Meat.xlsx").Worksheets("Meat").Cells(b + 1, 1).Select
ActiveSheet.Paste
ThisWorkbook.Worksheets("Products").Activate
End If
Next
On Error Resume Next '1004 error kept appearing so this function allows us to continue to next step without error appearing
ThisWorkbook.Worksheets("Products").Cells(1, 1).Select
End With
MsgBox "All rows from Products worksheet have been copied."
Application.ScreenUpdating = True
End Sub
Any help is greatly appreciated. Thanks.
Use Find to check if Tracking Number exists and to locate row when transferring data back to Products.
Option Explicit
Sub CommandButton1_Click()
' update meat
Const PATH = "\\SCF1\USERS-D\Robert\My Documents\Excel VBA code\"
Const WB_NAME = "Meat.xlsx"
Dim wb As Workbook, ws As Worksheet, iLastRow As Long, iRow As Long
Dim wbTarget As Workbook, wsTarget As Worksheet, iTargetRow As Long
Set wbTarget = Workbooks.Open(PATH & WB_NAME)
Set wsTarget = wbTarget.Sheets("Meat")
iTargetRow = wsTarget.Cells(Rows.count, 1).End(xlUp).Row + 1
Set wb = ThisWorkbook
Set ws = wb.Sheets("Products")
iLastRow = ws.Cells(Rows.count, 1).End(xlUp).Row
Dim sContent As String, sTrackId As String
Dim res As Variant, count As Long
'Application.ScreenUpdating = False
count = 0
For iRow = 2 To iLastRow
sTrackId = ws.Cells(iRow, "A")
sContent = ws.Cells(iRow, "I")
If LCase(sContent) Like "*meat*" Then
' check not already on sheet
Set res = wsTarget.Range("A:A").Find(sTrackId)
If (res Is Nothing) Then
ws.Rows(iRow).Copy wsTarget.Cells(iTargetRow, 1)
iTargetRow = iTargetRow + 1
count = count + 1
End If
End If
Next
'wbTarget.Save
'wbTarget.Close
MsgBox count & " rows inserted from Products worksheet."
'Application.ScreenUpdating = True
End Sub
Sub CommandButton2_Click()
' update product
Const PATH = "\\SCF1\USERS-D\Robert\My Documents\Excel VBA code\"
Const WB_NAME = "Meat.xlsx"
Dim wb As Workbook, ws As Worksheet, iRow As Long
Dim wbSource As Workbook, wsSource As Worksheet, iLastSourceRow As Long
Set wbSource = Workbooks.Open(PATH & WB_NAME, False, True) 'no link update, read-only
Set wsSource = wbSource.Sheets("Meat")
iLastSourceRow = wsSource.Cells(Rows.count, 1).End(xlUp).Row + 1
Set wb = ThisWorkbook
Set ws = wb.Sheets("Products")
Dim sTrackId As String
Dim res As Variant, count As Long
'Application.ScreenUpdating = False
count = 0
For iRow = 2 To iLastSourceRow
sTrackId = wsSource.Cells(iRow, "A")
' find row on product sheet
Set res = ws.Range("A:A").Find(sTrackId)
If (res Is Nothing) Then
MsgBox "Could not update " & sTrackId, vbExclamation
Else
wsSource.Rows(iRow).Copy ws.Cells(res.Row, 1)
count = count + 1
End If
Next
wbSource.Close
MsgBox count & " rows updated from Meat workbook."
'Application.ScreenUpdating = True
End Sub

Extracting Data from Excel Database

I've got a database with a long list of names, and unique values associated with the names. What I want to do is create one worksheet for each individual, and then copy only their data to a specified range in their worksheet, then proceed to the next individual, copy their data to their worksheet etc.
Here is a link to an example worksheet (in google docs form, note - I am actually using Excel 2010, not google docs).
I've been able to create all the worksheets through using the following code in a new sheet I called "Employee". All I did to this sheet was remove the duplicate name values so I could have a list of all the names for the worksheets.
Any help is much appreciated. Thanks in advance.
Sub CreateSheetsFromAList()
Dim nameSource As String 'sheet name where to read names
Dim nameColumn As String 'column where the names are located
Dim nameStartRow As Long 'row from where name starts
Dim nameEndRow As Long 'row where name ends
Dim employeeName As String 'employee name
Dim newSheet As Worksheet
nameSource = "Employee"
nameColumn = "A"
nameStartRow = 1
'find the last cell in use
nameEndRow = Sheets(nameSource).Cells(Rows.Count, nameColumn).End(xlUp).Row
'loop till last row
Do While (nameStartRow <= nameEndRow)
'get the name
employeeName = Sheets(nameSource).Cells(nameStartRow, nameColumn)
'remove any white space
employeeName = Trim(employeeName)
' if name is not equal to ""
If (employeeName <> vbNullString) Then
On Error Resume Next 'do not throw error
Err.Clear 'clear any existing error
'if sheet name is not present this will cause error that we are going to leverage
Sheets(employeeName).Name = employeeName
If (Err.Number > 0) Then
'sheet was not there, so it create error, so we can create this sheet
Err.Clear
On Error GoTo -1 'disable exception so to reuse in loop
'add new sheet
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
'rename sheet
newSheet.Name = employeeName
'paste training material
Sheets(employeeName).Cells(1, "A").PasteSpecial
Application.CutCopyMode = False
End If
End If
nameStartRow = nameStartRow + 1 'increment row
Loop
End Sub
Bare bones approach - could be optimized for better performance, but it will do the job.
Sub SplitToSheets()
Dim c As Range, ws As Worksheet, rngNames
With ThisWorkbook.Sheets("EmployeeData")
Set rngNames = .Range(.Range("A1"), .Cells(Rows.Count, 1).End(xlUp))
End With
For Each c In rngNames.Cells
Set ws = GetSheet(ThisWorkbook, c.Value)
c.EntireRow.Copy ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
Next c
End Sub
Function GetSheet(wb As Workbook, wsName As String, _
Optional CreateIfMissing As Boolean = True) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = wb.Sheets(wsName)
On Error GoTo 0
If ws Is Nothing And CreateIfMissing Then
Set ws = wb.Sheets.Add(after:=wb.Sheets(wb.Sheets.Count))
ws.Name = wsName
End If
Set GetSheet = ws
End Function

Resources