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

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

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

澄清：基本工作簿行 – x xx xxx xxxx xxxxx … x XX

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

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

任何人都可以提供一些关于如何处理工作簿的方法吗？ 我不介意使用它，并试图让它工作，但承认自己在开始自动步进行，并通过引用基本工作簿中的单元格值保存新的工作簿。

感谢任何人能够提供的帮助。

macros的代码如下所示：

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

这是我想出来的。 我用工作表上的button运行这个代码，数据如下所示：

以下是附加到button1的代码：

 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处理，并正确的error handling。