Creating sheets with names in column B and assigning data to each sheet for particular name

0 votes

I want to create a sheet for each distinct name and copy and paste the data for that person to that sheet. I have a workbook with a master sheet in which I have assigned data to a group of persons. I created a code, however the problem is that it creates just one sheet with a list of first names and repeatedly copies each row into cell A1:H1. not changing the sheet's name or relocating to A2:H2.

Raw Data

Expected result

Sub CreateSheetsForNames()

Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim sht As Worksheet

Set ws = ThisWorkbook.Sheets("SM")
Set rng = ws.Range("B2", ws.Range("B" & Rows.Count).End(xlUp))

For Each cell In rng
    If Len(cell.Value) > 0 And Not IsNumeric(cell.Value) Then
        On Error Resume Next
        Set sht = ThisWorkbook.Sheets(cell.Value)
        On Error GoTo 0
        If sht Is Nothing Then
            Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            sht.Name = cell.Value
        End If
        ws.Range("A" & cell.Row & ":H" & cell.Row).Copy sht.Range("A1")
    End If
Next cell

End Sub
Feb 13, 2023 in Others by Kithuzzz
• 38,020 points
761 views

1 answer to this question.

0 votes

after the first occurrence of Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)), sht will NOT be Nothing even if Set sht = ThisWorkbook.Sheets(cell.Value) should fail

so be sure to set sht to Nothing at each iteration

while ... .Copy sht.Range("A1") will always be pasting from cell A1 of the target sheet, hence you have to update the target cell like with sht.Cells(Rows.Count, 1).End(xlUp).Offset(1)

So that you could use the following:

For Each cell In rng
    If Len(cell.Value) > 0 And Not IsNumeric(cell.Value) Then
        Set sht = Nothing ' set sht to Nothing and erase the result of the preceeding loop
        On Error Resume Next
        Set sht = ThisWorkbook.Sheets(cell.Value)
        On Error GoTo 0
        If sht Is Nothing Then
            Set sht = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            sht.Name = cell.Value
        End If
        ws.Range("A" & cell.Row & ":H" & cell.Row).Copy sht.Cells(Rows.Count, 1).End(xlUp).Offset(1) 'paste starting from column A first empty cell after last not empty one
    End If
Next cell
answered Feb 13, 2023 by narikkadan
• 63,720 points

Related Questions In Others

0 votes
1 answer
0 votes
0 answers

Data Driven Framework -- how to read and write in excel sheet using Selenium WebDriver with java

I'm using this code to read something, ...READ MORE

Oct 31, 2022 in Others by Kithuzzz
• 38,020 points
614 views
0 votes
1 answer

Excel VBA- How to loop through specific sheets in a workbook and format the same ranges in each sheet

Range(...) instructs VBA to always use the ...READ MORE

answered Mar 21, 2023 in Others by Kithuzzz
• 38,020 points
1,652 views
0 votes
2 answers
0 votes
1 answer

I want to compare two Excel files and highlight the differences with VBA

The workbook doesn't have the UsedRange property ...READ MORE

answered Jan 13, 2023 in Others by narikkadan
• 63,720 points
2,485 views
0 votes
1 answer

Sort numeric values VBA

Try: The formula in B1: =SORTBY(A1:A8,LEFT(A1:A8&"0000 ...READ MORE

answered Feb 11, 2023 in Others by Kithuzzz
• 38,020 points
408 views
0 votes
1 answer

Export All appointments and meetings (including recurring meetings) Excel VBA

However, when I use the code above ...READ MORE

answered Feb 13, 2023 in Others by narikkadan
• 63,720 points
1,582 views
0 votes
1 answer

Excel VBA creating a new Outlook appointment results in a cancelled appointment

Because an inappropriate sender will be used, ...READ MORE

answered Feb 14, 2023 in Others by Kithuzzz
• 38,020 points
778 views
0 votes
1 answer
0 votes
1 answer

Convert Feet to meters in excel with macro for entire column

You can convert Feet to Kilometers using ...READ MORE

answered Oct 27, 2022 in Others by narikkadan
• 63,720 points
670 views
webinar REGISTER FOR FREE WEBINAR X
REGISTER NOW
webinar_success Thank you for registering Join Edureka Meetup community for 100+ Free Webinars each month JOIN MEETUP GROUP