Excel VBA: For each row, generate new sheet and copy row to the new sheet

Question

I'm trying to get my spreadsheet to automatically generate new names and sheets based on a data dump. I currently have the sheet working so that it will generate the name and sheet for each row of data, but I cannot get it to populate the sheet using that row.

There is a specific section of code that I cannot get to work:

    For Each Nm In shNAMES
        If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
            wsTEMP.Copy After:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = CStr(Nm.Text)
            ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm) ' <<< This line here
        End If
    Next Nm

I know that the issue is using Nm to reference the cell (it's returning "OP01" which is the cell contents), but I'm trying to not add another workaround. I've tried using other functions to do similar after the Nm loop has finished, but can't seem to get those working either. Surely the answer has to be simple and I'm just missing something?

Option Explicit

Sub SheetsFromTemplate()

Application.ScreenUpdating = False

Rows("1:8").EntireRow.Delete

Call CreateLONums

Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long

With ThisWorkbook
    Set wsTEMP = .Sheets("Template")
    wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
    If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
    
    Set wsMASTER = .Sheets("Creation Page")
    Set wsINDEX = .Sheets("Local Options")
                                                                
    With Sheets("Creation Page").Columns("A")
        If WorksheetFunction.CountA(.Cells) = 0 Then
            MsgBox "Sorry: no data"
        Else
            With .SpecialCells(xlCellTypeConstants)
                firstrow = .Areas(1).Row
                lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
            End With
        End If
    End With

    Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
    
    For Each Nm In shNAMES
        If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
            wsTEMP.Copy After:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = CStr(Nm.Text)
            ActiveSheet.Range("A1:I1").Value = wsMASTER.Range("A" & Nm & ":I" & Nm)
        End If
        
    Next Nm
    
    wsINDEX.Activate
    If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden

End With

Worksheets("Creation Page").Delete
Worksheets("Template").Delete

Call CreateLinksToAllSheets

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

Sub CreateLONums()

Dim firstrow As Long, lastrow As Long, rowcount As Integer

Columns("A:A").Insert Shift:=xlToRight

With Sheets("Creation Page").Columns("B")
    If WorksheetFunction.CountA(.Cells) = 0 Then
        MsgBox "Sorry: no data"
    Else
        With .SpecialCells(xlCellTypeConstants)
            firstrow = .Areas(1).Row
            lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
        End With
    End If
    
    For rowcount = firstrow To firstrow + 9
        Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
    Next rowcount
    
    For rowcount = firstrow + 9 To lastrow
        Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
    Next rowcount

End With
    
End Sub

Appreciate any insight available.

[Spreadsheet - Google Drive Download](https://drive.google.com/file/d/17z1nfXNJaTLrLtNYpgN-qkSdRIsic1oV/view?usp=sharing) — Joobie, Feb 09 '21 at 23:03

score 0 · Answer 1 · answered Feb 10 '21 at 01:30

Managed to work it out, took way longer than it should have -.-'

I borrowed a bit of Function code to reference the number from column A, then used that to reference the cells that I wanted.

For Each Nm In shNAMES
        rownum = GetDigits(Nm) 'This bit here is calling the function
        If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
            wsTEMP.Copy after:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = CStr(Nm.Text)
            ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value `This is utilising rownum to reference the cells
        End If
    Next Nm

Function code can be found here: How to find numbers from a string?

Entire code section in case it is useful to someone in future:

Option Explicit


Sub SheetsFromTemplate()

Application.ScreenUpdating = False

Rows("1:8").EntireRow.Delete

Call CreateLONums

Dim wsMASTER As Worksheet, wsTEMP As Worksheet, wsINDEX As Worksheet, wasVISIBLE As Boolean
Dim shNAMES As Range, Nm As Range
Dim firstrow As Long, lastrow As Long, rownum As Integer

With ThisWorkbook
    Set wsTEMP = .Sheets("Template")
    wasVISIBLE = (wsTEMP.Visible = xlSheetVisible)
    If Not wasVISIBLE Then wsTEMP.Visible = xlSheetVisible
    
    Set wsMASTER = .Sheets("Creation Page")
    Set wsINDEX = .Sheets("Local Options")
                                                                
    With Sheets("Creation Page").Columns("A")
        If WorksheetFunction.CountA(.Cells) = 0 Then
            MsgBox "No Data Available"
        Else
            With .SpecialCells(xlCellTypeConstants)
                firstrow = .Areas(1).Row
                lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
            End With
        End If
    End With

    Set shNAMES = wsMASTER.Range("A" & firstrow, "A" & lastrow)
    
    For Each Nm In shNAMES
        rownum = GetDigits(Nm)
        If Not Evaluate("ISREF('" & CStr(Nm.Text) & "'!A1)") Then
            wsTEMP.Copy after:=.Sheets(.Sheets.Count)
            ActiveSheet.Name = CStr(Nm.Text)
            ActiveSheet.Range("A1:J1").Value = wsMASTER.Range("A" & rownum & ":J" & rownum).Value
        End If
    Next Nm
    
    wsINDEX.Activate
    If Not wasVISIBLE Then wsTEMP.Visible = xlSheetHidden

End With

Worksheets("Template").Move after:=Worksheets(Worksheets.Count)
Worksheets("Creation Page").Move after:=Worksheets(Worksheets.Count)

Call CreateLinksToAllSheets
Call UpdateIndexTechSpec
Call UpdateIndexOptDescription

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub


Sub CreateLONums()

Dim firstrow As Long, lastrow As Long, rowcount As Integer

Columns("A:A").Insert Shift:=xlToRight

With Sheets("Creation Page").Columns("B")
    If WorksheetFunction.CountA(.Cells) = 0 Then
        MsgBox "Sorry: no data"
    Else
        With .SpecialCells(xlCellTypeConstants)
            firstrow = .Areas(1).Row
            lastrow = .Areas(.Areas.Count).Cells(.Areas(.Areas.Count).Rows.Count).Row
        End With
    End If
    
    For rowcount = firstrow To firstrow + 9
        Range("A" & rowcount).Value = "OP0" & rowcount - firstrow + 1
    Next rowcount
    
    For rowcount = firstrow + 9 To lastrow
        Range("A" & rowcount).Value = "OP" & rowcount - firstrow + 1
    Next rowcount

End With
    
End Sub

Sub CreateLinksToAllSheets()

Dim sh As Worksheet
Dim cell As Range

Sheets("Local Options").Activate
ActiveSheet.Cells(10, 1).Select

For Each sh In ActiveWorkbook.Worksheets
    If ActiveSheet.Name <> sh.Name Then
        ActiveCell.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & sh.Name & "'" & "!A1", TextToDisplay:=sh.Name
        ActiveCell.Offset(1, 0).Select
    End If
Next sh

Call UpdateIndexTechSpec
Call UpdateIndexOptDescription

End Sub

Sub UpdateIndexTechSpec()

Dim sh As Worksheet
Dim cell As Range

Sheets("Local Options").Activate
ActiveSheet.Cells(10, 2).Select

For Each sh In ActiveWorkbook.Worksheets
    If ActiveSheet.Name <> sh.Name Then
        ActiveCell.Value = sh.Range("B2").Value
        ActiveCell.Offset(1, 0).Select
    End If
Next sh

End Sub

Sub UpdateIndexOptDescription()

Dim sh As Worksheet
Dim cell As Range

Sheets("Local Options").Activate
ActiveSheet.Cells(10, 3).Select

For Each sh In ActiveWorkbook.Worksheets
    If ActiveSheet.Name <> sh.Name Then
        ActiveCell.Value = sh.Range("D2").Value
        ActiveCell.Offset(1, 0).Select
    End If
Next sh

End Sub

Function GetDigits(ByVal s As String) As String
    Dim char As String
    Dim i As Integer
    GetDigits = ""
    For i = 1 To Len(s)
        char = Mid(s, i, 1)
        If char >= "0" And char <= "9" Then
            GetDigits = GetDigits + char
        End If
    Next i
End Function

Excel VBA: For each row, generate new sheet and copy row to the new sheet

1 Answers1