从具有动态自动调整 VBA 范围的工作表创建工作簿

Question

我有一个包含数个工作表的工作簿，其中包含数百个需要拆分为单独工作簿的价格网格（每个工作簿一个价格网格）。这里所需的 VBA 水平在很大程度上超出了我对该主题的基本知识，如果您愿意提供任何帮助，我将不胜感激。

每个工作表都有许多不同大小的网格，由空白行和空白列分隔：

+---------+------+------+------+------+------+ |产品1 | | 100 | 200 | 300 | 400 | |产品2 | 600 |第862章第976章1024 |第1456章 |产品3 | 800 | 975 | 1076 |第1156章第1287章 |产品4 | 1000 | 1076 |第1187章第1245章1867 | | | 1200 |第1187章第1294章第1354章| +---------+------+------+------+------+------+

我需要为每个产品制作一个 Excel 文件/工作簿。每个工作簿的名称将是 A 列中的产品名称，内容必须是没有 A 列的完整网格，因此只有所有数字。每个工作簿都可以保存在 ActiveWorkbook.Path 中。给定的示例将生成 4 个名为 Product1、Product2、Product3 和 Product4 的文件。每个文件将仅包含从单元格 A1 开始的定价网格，如示例所示，该网格有时为空。

以下代码选择工作表上的每个价格网格块，但我不确定如何遍历数据以提取产品名称。此示例中的“Sheet1”和“A1”也需要是动态值，它会循环遍历所有工作表并找到每个工作表上的所有块。

Sub DynamicRange()

Dim sht As Worksheet
Dim StartCell As Range

Set sht = Worksheets("Sheet1")
Set StartCell = Range("A1")

StartCell.CurrentRegion.Select

End Sub

请帮忙？

Answer 1

谢谢丹尼尔……我搞定了。

Sub ExtractGridsMS()

Dim wbAllProducts As Workbook
Dim wsAllProducts As Worksheet

Set wbAllProducts = ThisWorkbook

For Each wsAllProducts In wbAllProducts.Sheets
    MkDir wbAllProducts.Path & "\" & wsAllProducts.Name
    For Each it In wsAllProducts.Columns(1).SpecialCells(2)
    With Workbooks.Add
        it.CurrentRegion.Offset(, 1).Copy .Sheets(1).Cells(1)
        .SaveAs wbAllProducts.Path & Application.PathSeparator & wsAllProducts.Name & Application.PathSeparator & it.Value & ".xls", xlExcel8
        .Close 0
    End With
    Next it
ChDir ".\.."
Next wsAllProducts

结束子

Answer 2

解决方案将取决于数据的分离方式。你的例子不清楚。

您说数据由一个空白行和一个空白列分隔。是哪个？

您还说您希望将工作簿命名为 Product1、Product2 等，但在您的示例中，最后一行是空白的。工作簿不能有空白名称。

假设您可以选择范围，下面是一些循环工作表并输出工作簿的代码。

Option Explicit

Sub loopThroughSheets()
    Dim ws  As Worksheet
    Dim rng As Range

    For Each ws In ActiveWorkbook.Sheets
        ' ... some loop to select ranges here ...
            Call outputRange(rng)
    Next ws

End Sub

Sub outputRange(rng As Range)
    Dim wb      As Workbook
    Dim arry()  As Variant
    Dim i       As Integer
    Dim j       As Integer
    Dim wbName  As String
    arry = rng'assigns range values to variant array

    Application.DisplayAlerts = False
    For i = 1 To UBound(arry, 1)
        Set wb = Workbooks.Add
        wbName = arry(i, 1)
        For j = 2 To UBound(arry, 2)
            wb.Sheets(1).Cells(1, j - 1) = arry(i, j)
        Next j
        Wk.SaveAs Filename:=(ActiveWorkbook.Path & "\" & wb.name & ".xlsx")
    Next i

    Application.DisplayAlerts = True
End Sub