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

Question

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

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

为了澄清： 基本工作簿行 - x xx xxx xxxx 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").Activate~ 行的范围。

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

输出如下：

如果您希望我详细解释代码，请告诉我！

编辑：更新的代码：添加了Application.ScreenUpdating 处理和正确的错误处理。