Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

**DocAElstein** · 10-08-2023, 06:45 PM

Some extra notes for this Post
https://www.excelfox.com/forum/showt...ll=1#post23399

Code:

Sub GenerateWorkbooksPerName()
    
    Const REPEATING_ROWS As Long = 6
    Const NAME_DELIMITER As String = " "
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim sws As Worksheet: Set sws = swb.Worksheets("CROSSACT")
    
    Dim FirstRow As Long: FirstRow = REPEATING_ROWS + 1
    
    With sws.UsedRange
        If .Rows.Count < FirstRow Then Exit Sub
    End With
    
    Application.ScreenUpdating = False
    
    sws.Copy
    
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    Dim dws As Worksheet: Set dws = dwb.Sheets(1)
    
    With dws.UsedRange
        .Resize(.Rows.Count - REPEATING_ROWS).Offset(REPEATING_ROWS).Clear
    End With
    
    Dim dfCell As Range: Set dfCell = dws.Cells(FirstRow, "A")
    
    Dim dFolderPath As String:
    dFolderPath = swb.Path & Application.PathSeparator

    Dim ndLen As Long: ndLen = Len(NAME_DELIMITER)
    
    Dim r As Long, dCount As Long, dFilePath As String, dName As String
    
    For r = FirstRow To sws.Cells(sws.Rows.Count, "A").End(xlUp).Row
        sws.Rows(r).Copy dfCell
        dName = CStr(sws.Cells(r, "A").Value) & NAME_DELIMITER _
            & CStr(sws.Cells(r, "B").Value)
        If Len(dName) > ndLen Then
            dws.Name = dName
            dFilePath = dFolderPath & dName & ".xlsx"
            Application.DisplayAlerts = False
                dwb.SaveAs dFilePath, xlOpenXMLWorkbook
            Application.DisplayAlerts = True
            dCount = dCount + 1
        End If
    Next r
    
    dwb.Close SaveChanges:=False
    
    Application.ScreenUpdating = True
    
    MsgBox dCount & " workbook" & IIf(dCount = 1, "", "s") & " generated.", _
        IIf(dCount = 0, vbCritical, vbInformation)
    
End Sub

Thread: Appendix Thread 2. ( Codes for other Threads, HTML Tables, etc.)

Thread Tools

Display

Threaded View

Similar Threads

VBA to Reply All To Latest Email Thread

Appendix Thread. Diet Protokol Coding Adaptions

Just testing a before a possible Thread post. No reply needed

Search List of my codes

Bookmarks

Bookmarks

Posting Permissions