Member Avatar for Divinedar

Ok I have a a list of about 392 items that needs to be put into an excel form. I manage to get Column A (which is the inserted worksheet names) to name the worksheets that is automatically inserted.

I have attached an example of my table

When the code names names the see it also puts that same name in cell "N8"

From the table I also need for the code to put in the information from that same line to insert various cells from the table. When you look at the attachment the columns that is highlighted in row 2.

The code is in MODULE 2 of the attached file.

Let me know if you need anything else.

  • 1 Contributor
  • 1 Reply
  • 508 Views
  • 2 Weeks Discussion Span
  • Latest Post Latest Post by Divinedar

Dani AI

Generated

Good job, — your copy-template + loop approach is working and RebuildSell shows the workflow is sound. Two things will simplify and speed it up for ~400 rows: read the source table into one Variant array, and copy the template with Worksheet.Copy (no Select/Activate). That removes repeat Range/End calls, reduces screen flicker, and is much faster.

Below is a compact pattern you can adapt. It reads the source block to an array, uses a small mapping table (source column → target address on the template), copies the template for each row, writes the mapped values, and sanitizes sheet names.

Sub CreateSheetsFromTable()
    Dim srcWS As Worksheet, tplWS As Worksheet, dstWS As Worksheet
    Dim dataArr As Variant, lastRow As Long, r As Long, j As Long
    Dim map As Variant

    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set srcWS = ThisWorkbook.Worksheets("Source")    'change
    Set tplWS = ThisWorkbook.Worksheets("Template")  'change

    lastRow = srcWS.Cells(srcWS.Rows.Count, 1).End(xlUp).Row
    If lastRow < 2 Then GoTo Cleanup

    dataArr = srcWS.Range(srcWS.Cells(2, 1), srcWS.Cells(lastRow, 6)).Value
    map = Array(Array(1, "B4"), Array(2, "C4"), Array(3, "D4")) 'srcColIndex, targetAddr

    For r = 1 To UBound(dataArr, 1)
        tplWS.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        Set dstWS = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        dstWS.Name = SafeSheetName(CStr(dataArr(r, 1)))
        For j = LBound(map) To UBound(map)
            dstWS.Range(map(j)(1)).Value = dataArr(r, map(j)(0))
        Next j
    Next r

Cleanup:
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Function SafeSheetName(s As String) As String
    Dim invalidChars As String, i As Long, base As String, suffix As Long
    invalidChars = "[]:*?/" & "\"   'replace invalid chars
    For i = 1 To Len(invalidChars): s = Replace(s, Mid(invalidChars, i, 1), "-"): Next i
    If Len(s) > 31 Then s = Left(s, 31)
    base = s: suffix = 1
    Do While SheetExists(s)
        s = Left(base, 31 - Len("_" & CStr(suffix))) & "_" & CStr(suffix)
        suffix = suffix + 1
    Loop
    SafeSheetName = s
End Function

Function SheetExists(name As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets(name)
    SheetExists = Not ws Is Nothing
    On Error GoTo 0
End Function

Quick tips:

  • Avoid End(xlDown) from a single cell if the column can have blanks; use End(xlUp) from the bottom or a named Table (ListObject).
  • Turn off events/calculation and restore them in an error handler to avoid leaving Excel in a changed state.
  • If you hit duplicate or invalid sheet names, SafeSheetName above resolves both.
  • For maximum speed, build an output array and write whole blocks with Range.Resize.Value rather than many individual writes.

This keeps your existing template/copy steps (and your applydata idea) but reduces worksheet calls, improves robustness, and makes the code easier to maintain.

Member Avatar for Divinedar

Ok so I wrote my own code which works pretty good but I know it can be less steps in the process.

Sub RenameNewSheet()
    Dim MyCell As Range, MyRange As Range, MyRange1, MyRange2, MyRange3, MyRange4, MyRange5, MyRange6, MyRange7, MyRange8, MyRange9
    Dim wsSource As Worksheet

    'This Macro will create separate tabs based on a list in Distribution Tab A2 down

    Worksheets("WBS_Items").Select

    'Column A WBS No
    Set MyRange = Sheets("WBS_Items").Range("A9")
    Set MyRange = Range(MyRange, MyRange.End(xlDown))

    'Column B Part No
    Set MyRange1 = Sheets("WBS_Items").Range("Partno")
    Set MyRange1 = Range(MyRange1, MyRange1.End(xlDown))

    'Column C Description
    Set MyRange2 = Sheets("WBS_Items").Range("Desc")
    Set MyRange2 = Range(MyRange2, MyRange2.End(xlDown))

    'Column D Qty
    Set MyRange3 = Sheets("WBS_Items").Range("QTY")
    Set MyRange3 = Range(MyRange3, MyRange3.End(xlDown))

    'Column E Each
    Set MyRange4 = Sheets("WBS_Items").Range("EachAmt")
    Set MyRange4 = Range(MyRange4, MyRange4.End(xlDown))

    'Column G Material Cost1
    Set MyRange5 = Sheets("WBS_Items").Range("MATCOST")
    Set MyRange5 = Range(MyRange5, MyRange5.End(xlDown))

    'Column J Material Cost Freight Estimate
    Set MyRange6 = Sheets("WBS_Items").Range("MTLFRGT")
    Set MyRange6 = Range(MyRange6, MyRange6.End(xlDown))

    'Column X Quality Labor Hours
    Set MyRange7 = Sheets("WBS_Items").Range("X13")

    'Column X Assembly Wireman Labor Hours
    Set MyRange8 = Sheets("WBS_Items").Range("X15")

    'Column M Material and Labor markup %
    Set MyRange9 = Sheets("WBS_Items").Range("X15")

    Dim MyDate

    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each MyCell In MyRange

'        Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
        copy_template
            Sheets("Newsht").Activate
            Sheets("Newsht").Cells(23, 6) = "1"
            Range("E8").Value = Sheets("PROJECT_INFORMATION").Range("A2")
            MyDate = Sheets("PROJECT_INFORMATION").Range("G2")
            Range("G8").Value = MyDate
            Range("I8").Value = Sheets("PROJECT_INFORMATION").Range("D2")
            Range("A1").Select
            Sheets("Newsht").Cells(23, 6) = "0"

            applydata

            Sheets("Newsht").Select

            Sheets("Newsht").Name = MyCell.Value ' renames the new worksheet

            Range("N8").Value = MyCell.Value 'add wbs no to worksheet

            Range("A1").Select

   Next MyCell

HideSheets

    RebuildSell
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Then it rebuilds my summary page adds columns. Perfect. It inserts all over 300 lines into a master worksheet.

Be a part of the DaniWeb community

We're a friendly, industry-focused community of developers, IT pros, digital marketers, and technology enthusiasts meeting, networking, learning, and sharing knowledge.