使用動態自動調整VBA範圍從工作表創建工作簿

Question

我有幾張工作表，其中包含數百個需要分成單個工作簿（每個工作簿一個價格網格）的價格網格。這裏所需的VBA水平在很大程度上超過了我對這個主題的基本知識，我將不勝感激您願意給予的幫助。

每個工作表中有許多由空白行和空白列分隔不同大小的這些網格：

 
+----------+------+------+------+------+------+ 
| Product1 |  | 100 | 200 | 300 | 400 | 
| Product2 | 600 | 862 | 976 | 1024 | 1456 | 
| Product3 | 800 | 975 | 1076 | 1156 | 1287 | 
| Product4 | 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

解決方案將取決於數據如何分離。你的例子不清楚。

你說數據被一個空白行和一個空白列分開。這是什麼？

你也說你想讓工作簿命名爲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 

Answer 2

謝謝丹尼爾......我明白了。

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 

End Sub