PDA

View Full Version : [SOLVED] Create Workbooks from Worksheets with Dynamic Auto-Adjusting VBA Ranges



CherylMc
07-12-2017, 10:24 PM
I have a workbook with several sheets containing hundreds of price grids that need to be split into individual workbooks (one price grid per workbook). The level of VBA required here largely exceeds my basic knowledge of the subject and I would greatly appreciate any help you are willing to give.


Each worksheet has a number of these grids of varying sizes separated by a blank row:




Product1

600
800
1000
1200
1400
1600
1800
2000
2200


Product2
600
985
1269
1566
1779
2123
2287
2441
2599
2733


Product3
800
1441
1998
2589
2963
3678
3925
4148
4374
4548


Product4
1000
1555
2179
2844
3258
4066
4334
4574
4817
5001



1200
1667
2363
3101
3553
4456
4745
5001
5259
5454



1400
1782
2543
3357
3849
4844
5154
5427
5703
5906



1600
1896
2724
3613
4144
5233
5565
5854
6146
6359



1800
2009
2907
3868
4439
5621
5972
6280
6592
6812



2000
2123
3088
4124
4734
6008
6382
6707
7035
7265



2200
2238
3272
4381
5031
6399
6792
7134
7478
7718



2400
2350
3452
4637
5329
6786
7202
7560
7921




2600
2464
3636
4892
5624
7176
7613
7986

















Product5

600
800
1000
1200
1400
1600
1800
2000
2200


Product6
600
1073
1408
1762
2004
2421
2602
2770
2940
3081



800
1667
2363
3101
3553
4456
4745
5001
5259
5454



1000
1818
2599
3436
3941
4964
5279
5559
5841
6044



1200
1966
2838
3771
4328
5469
5815
6116
6422
6638



1400
2114
3074
4104
4712
5979
6353
6674
6999
7232



1600
2264
3314
4439
5099
6487
6887
7232
7580
7823



1800
2412
3550
4774
5486
6996
7422
7790
8161
8417



2000
2560
3789
5109
5874
7504
7957
8348
8741
9007



2200
2710
4026
5443
6261
8013
8492
8905
9322
9601



2400
2858
4266
5778
6648
8522
9030
9464
9899
10191



2600
3006
4502
6113
7035
9030
9564
10021
10480
10786




I need to make one Excel file/workbook per product. The name of each workbook will be the product name from column A and the contents must be the full grid without column A, so just all the numbers. Each workbook can be saved in ActiveWorkbook.Path. The first grid in the given example would generate 4 files named Product1, Product2, Product3 and Product4. Each file would contain only the pricing grid starting in cell A1, which as shown in the example is sometimes empty.

The following code selects each price grid block on the worksheet but then I am unsure how to loop through the data to extract the product names. "Sheet1" and "A1" in this example would also need to be dynamic values, something that would loop through all sheets and find all the blocks on each sheet.




Sub DynamicRange()


Dim sht As Worksheet
Dim StartCell As Range


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


StartCell.CurrentRegion.Select


End Sub



Please help? :bug:

snb
07-13-2017, 12:55 AM
why disturbing a well built database ?

Remove the blank rows.
Add the productnames in all cells in column A
Transform it into an 'intelligent' table.
Use autofilter or advancedfilter.

CherylMc
07-13-2017, 03:05 AM
Hi snb, Thanks for your suggestion. Perhaps I need to clarify...
In the example Product1 refers to the full 2D grid of 10 columns x 12 rows (or B1:K12 in this case). Product2 refers to that same 2D grid so the output for the first grid would be 4 identical files named product1.xls, product2.xls, and so on. The second grid for products 5 & 6 would generate 2 identical files containing the grid to their right, also 10 columns x 12 rows, named product5.xls and product6.xls. I need all the grids in separate files as described to feed into a 3rd party program that requires the data in this format.

mdmackillop
07-13-2017, 03:13 AM
I'm not seeing the separation you describe. Can you post your example as a workbook Go Advanced/Manage Attachments

snb
07-13-2017, 03:20 AM
Please specify the exportformat: CSV, xlsx, ....

SamT
07-13-2017, 06:44 AM
THis is not real code, it needs to be fleshed out


Dim ProductCell As Range
Dim PriceGrid As Range

Set ProductCell = Cells(Rows.Count, "A").End(xlUp)

Do
Do
Set PriceGrid = ProductCel.CurrentRegion.OffSet(, 1)
'Make new workbook with one sheet, named ProductCell. Copy PriceGrid to New book sheet 1

If Productcell.Row = 1 then Exit Loop
Set Productcell = productcell.ofset(-1)
While ProductCell <>""
Set ProductDell = Productcell.end(xlUp
Loop


That assumes that each price grid is deeper than its pertinent product list. If not, insert another empty Row beneath that grid.

CherylMc
07-13-2017, 07:20 AM
Thanks for the help...
I have attached the data. The output format is .xls

Paul_Hossler
07-13-2017, 07:29 AM
Try this -




Option Explicit
Sub MakeWorkbooks()
Dim wbAllProducts As Workbook, wbProduct As Workbook
Dim wsAllProducts As Worksheet, wsTemp As Worksheet
Dim rAllData As Range, rAllProducts As Range, rBlock As Range, rMarker As Range, rProduct As Range
'init
Set wbAllProducts = ThisWorkbook
Set wsAllProducts = wbAllProducts.Worksheets("AllProducts")

With wsAllProducts
'get multi-area range with the product blocks
Set rMarker = .Cells(1, 1)
Set rAllProducts = rMarker.CurrentRegion

Set rMarker = rMarker.End(xlDown)

Do While rMarker.Row <> .Rows.Count
Set rAllProducts = Union(rAllProducts, rMarker.CurrentRegion)
Set rMarker = rMarker.End(xlDown)
Loop
End With

'copy each block to temp sheet
For Each rBlock In rAllProducts.Areas

wbAllProducts.Worksheets.Add
Set wsTemp = ActiveSheet

'delete products from temp sheet
rBlock.Copy wsTemp.Cells(1, 1)
wsTemp.Columns(1).Delete

'copy temp sheet to new wb
wsTemp.Copy
Set wbProduct = ActiveWorkbook

'save new wb once for each product in block
For Each rProduct In rBlock.Columns(1).SpecialCells(xlCellTypeConstants).Cells

'kill if exists
On Error Resume Next
Kill wbAllProducts.Path & Application.PathSeparator & rProduct.Value & ".xls"
On Error GoTo 0

'save as new wb
wbProduct.SaveAs wbAllProducts.Path & Application.PathSeparator & rProduct.Value & ".xls", xlExcel8
Next

wbProduct.Close

Application.DisplayAlerts = False
On Error Resume Next
wsTemp.Delete
On Error GoTo 0
Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
End Sub

CherylMc
07-13-2017, 02:27 PM
Wonderful! Thank you Paul, that works perfectly for a single worksheet. Could you help me to get it to loop through all worksheets? I tried adding a "For Each wsAllProducts In ActiveWorkbook.Sheets" loop but haven't been able to get it right.

snb
07-13-2017, 02:37 PM
I'd suggest:


Sub M_snb()
For Each it In Sheets("Roller").Columns(1).SpecialCells(2)
With Workbooks.Add
it.CurrentRegion.Copy .Sheets(1).Cells(1)
.Sheets(1).Columns(1).Delete
.SaveAs "G:\OF\" & it.Value & ".xls", 50
.Close 0
End With
Next
End Sub

Paul_Hossler
07-13-2017, 02:51 PM
Wonderful! Thank you Paul, that works perfectly for a single worksheet. Could you help me to get it to loop through all worksheets? I tried adding a "For Each wsAllProducts In ActiveWorkbook.Sheets" loop but haven't been able to get it right.


Probably something like this. Not thoroughly tested



Option Explicit
Sub MakeWorkbooks()
Dim wbAllProducts As Workbook, wbProduct As Workbook
Dim wsAllProducts As Worksheet, wsTemp As Worksheet
Dim rAllData As Range, rAllProducts As Range, rBlock As Range, rMarker As Range, rProduct As Range
'init
Set wbAllProducts = ThisWorkbook

For Each wsAllProducts In wbAllProducts.Worksheets
With wsAllProducts
'get multi-area range with the product blocks
Set rMarker = .Cells(1, 1)
Set rAllProducts = rMarker.CurrentRegion

Set rMarker = rMarker.End(xlDown)

Do While rMarker.Row <> .Rows.Count
Set rAllProducts = Union(rAllProducts, rMarker.CurrentRegion)
Set rMarker = rMarker.End(xlDown)
Loop
End With

'copy each block to temp sheet
For Each rBlock In rAllProducts.Areas

wbAllProducts.Worksheets.Add
Set wsTemp = ActiveSheet

'delete products from temp sheet
rBlock.Copy wsTemp.Cells(1, 1)
wsTemp.Columns(1).Delete

'copy temp sheet to new wb
wsTemp.Copy
Set wbProduct = ActiveWorkbook

'save new wb once for each product in block
For Each rProduct In rBlock.Columns(1).SpecialCells(xlCellTypeConstants).Cells

'kill if exists
On Error Resume Next
Kill wbAllProducts.Path & Application.PathSeparator & rProduct.Value & ".xls"
On Error GoTo 0

'save as new wb
wbProduct.SaveAs wbAllProducts.Path & Application.PathSeparator & rProduct.Value & ".xls", xlExcel8
Next

wbProduct.Close

Application.DisplayAlerts = False
On Error Resume Next
wsTemp.Delete
On Error GoTo 0
Application.DisplayAlerts = True
Next
Next

Application.ScreenUpdating = True
End Sub

snb
07-14-2017, 12:19 AM
Sub M_snb()
For Each it In Sheets("Roller").Columns(1).SpecialCells(2)
With Workbooks.Add
it.CurrentRegion.offset(,1).Copy .Sheets(1).Cells(1)
.SaveAs "G:\OF\" & it.Value & ".xls", 50
.Close 0
End With
Next
End Sub

CherylMc
07-15-2017, 12:13 AM
Thank you all. These solutions helped enormously. Very much appreciated! :clap: