Creating a new workbook for each row in an existing workbook

Question

I am trying to use one excel sheet that contains several rows of data and create separate workbooks for each of those rows using one of the values in the row as the new workbook name. These workbooks will be saved as comma delimited workbooks so they can be uploaded into the controller for a piece of machinery. I can manually open a new workbook and get the externally reference the cells from the base workbook but am confused on how to write the loop to have it automatically move through the rows and create a new workbook and how to use one of the values as the name for the new workbook.

The base workbook is structured in rows from A to J where column A contains the value I want to save the new workbook as. The new workbook needs to transpose the values and break the row into two columns (this is due to the structure of the control program on the machine and not something I can change). The first column in the new workbook would contain the values from B to H and the second column would contain values from I and J.

For clarification: Base workbook row - x xx xxx xxxx xxxxx ... X XX

New workbook format - The small x's would be column entries in A and the capital X would be column entries in B.

I am able to do the above and convert the row to two separate columns in a new workbook. I have also tried looking at the similar questions and responses for this but haven't been able to piece together a way to make the above work.

Can anyone give some ideas on how to approach writing the loop for the workbook? I don't mind playing with it and trying to get it to work but admit to being over my head in getting started with automatically stepping through the rows and saving the new workbook by referencing a cell value in the base workbook.

Thanks for any help anyone is able to provide.

The code from the Macro is listed below:

Sub Macro6()
'
' Macro6 Macro
'
' Keyboard Shortcut: Ctrl+q
'
    Workbooks.Add
    Application.Left = 721
    Application.Top = 1
    Application.Width = 720
    Application.Height = 780
    Windows("TEST.xlsx").Activate
    Range("B2:H2").Select
    Selection.Copy
    Windows("Book10").Activate
    Range("A1:A7").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("B1").Select
    Windows("B9 for Import TEST.xlsx").Activate
    Range("I2:J2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Book10").Activate
    Range("B1:B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Windows("TEST.xlsx").Activate
End Sub

It will work copy over the data once but then tells me that the subscript is out of range highlighting the ~Windows("Book10").Activate~ line.

Answer 1

Here's what I came up with. I ran this code with a button on work sheet with data that looks like this:

Here's the code attached to button 1:

Sub Button1_Click()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error GoTo PROC_ERROR

Dim ThisWorkbook As Workbook, NewBook As Workbook
Dim ThisWorksheet As Worksheet, NewWs As Worksheet
Dim i As Integer, j As Integer, k As Integer, ExportCount As Integer

Set ThisWorkbook = ActiveWorkbook
Set ThisWorksheet = ThisWorkbook.Sheets("Sheet1")
ExportCount = 0

For i = 1 To 10
    If ThisWorksheet.Cells(i, 1) <> "" Then
        Set NewBook = Workbooks.Add
        Set NewWs = NewBook.Sheets("Sheet1")
        For j = 2 To 8
            If ThisWorksheet.Cells(i, j) <> "" Then
                NewWs.Cells(j - 1, 1) = ThisWorksheet.Cells(i, j)
            End If
        Next j
        For k = 9 To 10
            If ThisWorksheet.Cells(i, k) <> "" Then
                NewWs.Cells(k - 8, 2) = ThisWorksheet.Cells(i, k)
            End If
        Next k
        With NewBook
            .Sheets("Sheet2").Delete
            .Sheets("Sheet3").Delete
            .Title = ThisWorksheet.Cells(i, 1)
            .SaveAs Filename:=ThisWorksheet.Cells(i, 1) & ".csv", FileFormat:=xlCSV, CreateBackup:=False
        End With
        ExportCount = ExportCount + 1
    End If
Next i

PROC_ERROR:
If Err.Number <> 0 Then
    MsgBox "This macro has encountered an error and needs to exit. However, some or all of your exported workbooks may still have been saved. Please try again." _
    & vbNewLine & vbNewLine & "Error Number: " & Err.Number & vbNewLine & "Error Description: " & Err.Description, vbInformation
    ExportCount = 0
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub
Else
    MsgBox "Successfully exported " & ExportCount & " workbooks!", vbInformation
    ExportCount = 0
End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Output looks like this:

Let me know if you want me to explain the code in detail!

EDIT: Updated code: Added Application.ScreenUpdating handling, and proper Error Handling.