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（＆＃34; Book10＆＃34;）。激活〜行。

Answer 1

这就是我想出的。我使用工作表上的按钮运行此代码，其数据如下所示： enter image description here

这是附加到按钮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

输出如下所示： enter image description here

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

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

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

1 个答案: