VBA code to split data into multiple workbooks based on a column and transpose and merge data in each workbook

Question

I am a beginner in VBA and I have a requirement where I need to split data from a source worksheet into multiple workbooks based on a specific column (Order Number), and then transpose and merge data in each workbook.

Here are the details of my requirement, Please let me know if my requirement is not clear:

• Source Data: The source data is in a worksheet named "Contract Item Info". The data starts from cell A2 and includes the following columns: "Contract ID", "Line Number", "Extended Price", "Item Category", "Material Group", "Material Code", "Plant", "Requisition ID", "Requisition Item Number", "RFQID", "RFQ Item No", "Total Cost", "Discount Amount", "Discount percentage", "Surcharge Amount", "Surcharge Percentage", "Lead Time", "Request Delivery Date".

• Transpose and Merge Data: In the "Item Attributes" sheet of each split workbook, I want to transpose the data from the "Contract Item Info" sheet. The first column of the "Item Attributes" sheet should be the line number from the source data, and the remaining columns should match the structure provided.

• Splitting Criteria: I need to split the data into multiple workbooks based on the values in the "Contract ID" column. Each unique "Contract ID" should create a separate workbook.

• Workbook Structure: In each split workbook, I need two sheets: one sheet named "Contract Item Info" that contains the original data for that contract, and another sheet named "Item Attributes" that should be created with the same structure as provided. Let's say if this doesn't work. I am okay to create code to merge the files based on the contract ID as a filename-based.

• File Naming: Each split workbook should be saved with the name of the respective "Contract ID" value.

I have attempted to write the code, but I encountered difficulties achieving the desired outcome on transposing the data fields and splitting accordingly. Please find code below:

Option Explicit

Sub ExportToWorkbooks()
    
    Const aibPrompt As String = "Which column would you like to filter by?"
    Const aibtitle As String = "Filter Column"
    Const aibDefault As Long = 3
    
    Dim dFileExtension As String: dFileExtension = ".xlsx"
    Dim dFileFormat As XlFileFormat: dFileFormat = xlOpenXMLWorkbook
    Dim dFolderPath As String: dFolderPath = "C:\Test\"
    
    If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then Exit Sub ' folder not found
    If Left(dFileExtension, 1) <> "." Then dFileExtension = "." & dFileExtension
    
    Application.ScreenUpdating = False
    
    Dim sCol As Variant
    sCol = Application.InputBox(aibPrompt, aibtitle, aibDefault, , , , , 1)
    If Len(CStr(sCol)) = 0 Then Exit Sub ' no entry
    If sCol = False Then Exit Sub ' canceled
    
    Dim sws As Worksheet: Set sws = ActiveSheet
    If sws.AutoFilterMode Then sws.AutoFilterMode = False ' turn off AutoFilter
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < 3 Then Exit Sub ' not enough rows
    Dim srrg As Range: Set srrg = srg.Rows(1) ' to copy column widths
    Dim scrg As Range: Set scrg = srg.Columns(sCol)
    Dim scData As Variant: scData = scrg.Value
    
    ' Write the unique values from the 1st column to a dictionary.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case insensitive
    
    Dim Key As Variant
    Dim r As Long
    
    For r = 2 To srCount
        Key = scData(r, 1)
        If Not IsError(Key) Then ' exclude error values
            If Len(Key) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub ' only error values and blanks
    Erase scData
    
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim dfcell As Range
    Dim dFilePath As String
    
    For Each Key In dict.Keys
        ' Add a new (destination) workbook and reference the first cell.
        Set dwb = Workbooks.Add(xlWBATWorksheet) ' one worksheet
        Set dws = dwb.Worksheets(1)
        Set dfcell = dws.Range("A1")
        ' Copy/Paste
        srrg.Copy
        dfcell.PasteSpecial xlPasteColumnWidths
        srg.AutoFilter sCol, Key
        srg.SpecialCells(xlCellTypeVisible).Copy dfcell
        sws.ShowAllData
        dfcell.Select
        ' Rename the destination sheet to match the source sheet name
        dws.Name = sws.Name
        ' Save/Close
        dFilePath = dFolderPath & Key & dFileExtension ' build the file path
        Application.DisplayAlerts = False ' overwrite without confirmation
        dwb.SaveAs dFilePath, xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        dwb.Close SaveChanges:=False
    Next Key
    
    sws.AutoFilterMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Data exported.", vbInformation
    
End Sub

I would greatly appreciate any assistance in modifying the code to meet my requirements. Thank you in advance for your help!