ダイナミック自動調整VBA範囲を使用してワークシートからワークブックを作成

Question

ワークブックには、個別のワークブック（ワークブックごとに1つの価格グリッド）に分割する必要のある数百の価格グリッドが含まれています。ここで必要とされる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に保存することができます。この例では、Product1、Product2、Product3、Product4の4つのファイルが生成されます。各ファイルには、セル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