为现有工作簿中的每一行创建一个新工作簿

Question

我正在尝试使用一个包含多行数据的Excel工作表，并使用行中的一个值作为新工作簿名称为每一行创建单独的工作簿。这些工作簿将保存为逗号分隔的工作簿，以便它们可以上传到机器的控制器中。我可以手动打开一个新工作簿并从基本工作簿中获取单元格的外部引用，但对如何编写循环以使其自动在行中移动并创建新工作簿以及如何使用其中一个值作为新工作簿的名称感到困惑。

基本工作簿的结构是从A到J的行，其中A列包含我要将新工作簿保存为的值。新工作簿需要转置值并将行分成两列（这是由于机器上控制程序的结构，我不能更改）。新工作簿中的第一列将包含从B到H的值，第二列将包含来自I和J的值。

请澄清：基本工作簿行-x xx xxx xxxx xxxxx xxxxx。。。X XX

新的工作簿格式-小的x将是A中的列条目，大写的X将是B中的列条目。

我能够完成上述操作，并在新工作簿中将行转换为两个单独的列。我也尝试过看类似的问题和回答，但还没有拼凑出一种方法来实现上述工作。

有人能就如何为工作簿编写循环给出一些想法吗？我不介意玩它并尝试让它工作，但我承认，在开始自动单步遍历行并通过引用基本工作簿中的单元格值来保存新工作簿时，我有些不知所措。

感谢任何人提供的帮助。

宏中的代码如下所示：

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

它会复制一次数据，但会告诉我下标超出突出显示~Windows（“Book10”）的范围。激活~行。

Answer 1

下面是附在按钮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

如果你想让我详细解释代码，请告诉我！

编辑：更新的代码：添加了应用程序。屏幕更新处理和正确的错误处理。