Create Smaller Tables From Larger Source Data Table - VBA

[seattletimebandit]

Hello!

Trying to figure out how to take a table of data and split into individual smaller tables. The source data table columns and rows are variable, from a few columns/rows to quite a lot, so maybe a message box asking user to select Range?

or something like:

Dim c1 As Range
Dim c2 As Range
lastColumn = ActiveSheet.Cells(c1.Row, Columns.Count).End(xlToLeft).Column
For Each c2 In Range(Cells(c1.Row, 3), Cells(c1.Row, lastColumn)).

Start with User pasting the Source Data Table starting in Cell B2 (which is empty):

Source Data Table:

[Cell B2]	322-H7	323-H7	324-G8	325-C11	326-E10	327-E10
Benzene	0.00829 U	0.00717 U	0.00806 U	0.0077 U	0.0082 U	0.00797 U
Toluene	0.0237 U	0.0205 U	0.0231 U	0.022 U	0.0235 U	0.0228 U
Ethylbenzene	0.0297 U	0.0257 U	0.0288 U	0.0276 U	0.0293 U	0.0285 U
mp-Xylene	0.0593 U	0.0513 U	0.0577 U	0.0551 U	0.0587 U	0.0571 U
o-Xylene	0.0297 U	0.0257 U	0.0288 U	0.0276 U	0.0293 U	0.0285 U
Gasoline	5.93 U	5.13 U	5.77 U	5.51 U	5.87 U	5.71 U

<tbody>
</tbody>

Smaller tables output, can start one row down from source table for spacing(Note the column header moves to the left in Column B):

322-H7
Benzene	0.00829 U
Toluene	0.0237 U
Ethylbenzene	0.0297 U
mp-Xylene	0.0593 U
o-Xylene	0.0297 U
Gasoline	5.93 U

<tbody>
</tbody>

and so on..until entire Source Data Table has been split up.

Thoughts? Scripting.Dictionary? Not well versed in that complex coding, but have seen it work well on something similar, I just can get my head around tweaking the code I have to apply here.

Thanks! Russell

 

[seattletimebandit]

Mick,

Nicely done...or nearly, but really close [Awesome!]. Here's what I'm seeing:

The first generated small table's borders are formatted great (this table has 4 data columns [Col C to Col F] extracted from my source table); so far so good.

The next table generated (it has 5 columns of data) has interior horizontal borders removed in the first (chemicals) column (Col B) and the last data column (Col G), all columns in between each have vertical interior borders (as designed), but still have all the horizontal interior borders (it looks like they weren't removed in the code). Col B and Col G look great, the others in between, full border grid (except the top row, all vertical lines are gone).

The three remaining small tables in my test sheet have two data columns (Col C to Col D), one data column (Col C), and ten data columns (Col C to Col L), all still have interior horizontal border grids (and vertical borders, as well, full grids).

I stepped through (F8) each line to see if there was some kind of bust I could catch. See my comment in the code with the "<--"

I did make one change to remove the interior vertical border "For Hoz = 1 To col - 1" to "For Hoz = 0 To col - 1" forgetting that the top row of each new table needs no vertical interior borders.

I hope my explanations are clear. I'd send a copy of me Excel table, but I don't know how to do that.

Thanks a ton, Mick. This is going to be a great tool. I hope others can find a use for this.

Russell

Sub MG01Nov23()
Dim Rng As Range, Dn As Range, n As Long, Sp As Variant, col As Long
Dim K As Variant, Lst As Long, Rw As Long, Ac As Long, Hoz As Long

Set Rng = Range(Range("C2"), Cells(2, Columns.Count).End(xlToLeft))
Range("B2") = "Test"

With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

For Each Dn In Rng
Sp = Split(Dn.Value, "-")
    If Not .Exists(Sp(0) & "-" & Sp(1)) Then
        .Add Sp(0) & "-" & Sp(1), Sp(2)
    Else
        .Item(Sp(0) & "-" & Sp(1)) = .Item(Sp(0) & "-" & Sp(1)) & "," & Sp(2)
    End If
Next
Ac = 1

Set Rng = Range("B2", Range("B2").End(xlDown))

For Each K In .keys
    col = UBound(Split(.Item(K), ",")) + 1
    Rw = Rw + Rng.Count + 1
    Rng.Copy Rng.Offset(Rw).Resize(Rng.Count)
        Rng.Offset(Rw).Resize(Rng.Count).Borders.LineStyle = xlNone             
        Rng.Offset(Rw).Resize(Rng.Count).BorderAround Weight:=xlThin    
        Rng.Offset(Rw)(1).BorderAround Weight:=xlThin
    
    Rng.Offset(, Ac).Resize(, col).Copy Rng.Offset(Rw, 1)
    Rng.Offset(Rw, Ac).Resize(Rng.Count, col).Borders.LineStyle = xlNone        '<--this removes all borders from Col-C to Col-F in first table generated, 
                         but only removes the horizontal interior borders from Col-G in the second new table generated.  
                         All subsequent tables still have the horizontal borders in place.  No matter how many columns wide my source table is.
   
    For Hoz = 1 To col
   Rng.Offset(Rw, Hoz).BorderAround Weight:=xlThin
   Rng.Offset(Rw, Hoz)(1).BorderAround Weight:=xlThin
   
   Next Hoz
   
 For Hoz = 0 To col - 1  '<------- Russell changed from "1" to "0" to take out the vertical border after the first cell
   Rng.Offset(Rw, Hoz)(1).Borders(xlEdgeRight).LineStyle = xlNone
   Next Hoz
   
    Rng(1).Offset(Rw) = K
    Rng(1).Offset(Rw, 1).Resize(, col) = Split(.Item(K), ",")
                      
    Ac = Ac + col
    
Next K
    
    'Russell coded for aligning
    With ActiveSheet
        .Cells.Columns.AutoFit
        .Cells.HorizontalAlignment = xlCenter
        .Cells.VerticalAlignment = xlCenter
        .Cells.Range("B:B").IndentLevel = 1
    End With
    
End With
Range("B2") = ""
End Sub

 

[MickG]

If the first small table that comes off is correct and you just need to remove the horizontal lines from the subsequent small table then
Try removing the line below:-

Ac = Ac + col

I'm not quite sure how it got there. !!!

 

[seattletimebandit]

Mick,

That sort of worked. Formatted all the borders correctly, removed all the horizontal interior borders.

However, the data extracted from the source table in Col B to the end of columns is duplicated in each subsequent table.

i.e., all Col B data in each new table has the same data as presented in Col B of the source table. If the new tables have a Col C data set, all tables have the same data found in Col C of the source table, if there is a Col D, same data as Col D in source, and so on.

The header row in each small table works fine, splits as designed, vertical borders removed, it's just the data from Col B and beyond that is duplicated for each new table.


-Russell

 

[MickG]

I'm not doing very well for you at the moment !!!!

Try this, I've replaced the "Ac= Ac+Col" ( I new it was there for some reason, Ha Ha)
and changed a previous "Ac" for "1".
I think its should now be working.

[COLOR="Navy"]Sub[/COLOR] MG01Nov07
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, col [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Hoz [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]

[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("C2"), Cells(2, Columns.Count).End(xlToLeft))
Range("B2") = "Test"

[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
Sp = Split(Dn.Value, "-")
    [COLOR="Navy"]If[/COLOR] Not .Exists(Sp(0) & "-" & Sp(1)) [COLOR="Navy"]Then[/COLOR]
        .Add Sp(0) & "-" & Sp(1), Sp(2)
    [COLOR="Navy"]Else[/COLOR]
        .Item(Sp(0) & "-" & Sp(1)) = .Item(Sp(0) & "-" & Sp(1)) & "," & Sp(2)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
Ac = 1

[COLOR="Navy"]Set[/COLOR] Rng = Range("B2", Range("B2").End(xlDown))

[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    col = UBound(Split(.Item(K), ",")) + 1
    Rw = Rw + Rng.Count + 1
    Rng.Copy Rng.Offset(Rw).Resize(Rng.Count)
        Rng.Offset(Rw).Resize(Rng.Count).Borders.LineStyle = xlNone
        Rng.Offset(Rw).Resize(Rng.Count).BorderAround Weight:=xlThin
        Rng.Offset(Rw)(1).BorderAround Weight:=xlThin
        Rng.Offset(, Ac).Resize(, col).Copy Rng.Offset(Rw, 1)
        
        Rng.Offset(Rw, 1).Resize(Rng.Count, col).Borders.LineStyle = xlNone '[COLOR="Green"][B] "Ac" Changed to "1"[/B][/COLOR]
    '[COLOR="Green"][B]<--this removes all borders from Col-C to Col-F in first table generated,[/B][/COLOR]
    '[COLOR="Green"][B]  but only removes the horizontal interior borders from Col-G in the second new table generated.[/B][/COLOR]
    '[COLOR="Green"][B]  All subsequent tables still have the horizontal borders in place.  No matter how many columns wide my source table is.[/B][/COLOR]
   
    [COLOR="Navy"]For[/COLOR] Hoz = 1 To col
   Rng.Offset(Rw, Hoz).BorderAround Weight:=xlThin
   Rng.Offset(Rw, Hoz)(1).BorderAround Weight:=xlThin
   
   [COLOR="Navy"]Next[/COLOR] Hoz
   
 For Hoz = 0 To col - 1  '[COLOR="Green"][B]<------- Russell changed from "1" to "0" to take out the vertical border after the first cell[/B][/COLOR]
   Rng.Offset(Rw, Hoz)(1).Borders(xlEdgeRight).LineStyle = xlNone
   [COLOR="Navy"]Next[/COLOR] Hoz
   
    Rng(1).Offset(Rw) = K
    Rng(1).Offset(Rw, 1).Resize(, col) = Split(.Item(K), ",")
                      
    Ac = Ac + col '[COLOR="Green"][B]"This line Returned[/B][/COLOR]
    
[COLOR="Navy"]Next[/COLOR] K
    
    '[COLOR="Green"][B]Russell coded for aligning[/B][/COLOR]
    [COLOR="Navy"]With[/COLOR] ActiveSheet
        .Cells.Columns.AutoFit
        .Cells.HorizontalAlignment = xlCenter
        .Cells.VerticalAlignment = xlCenter
        .Cells.Range("B:B").IndentLevel = 1
    [COLOR="Navy"]End[/COLOR] With
    
[COLOR="Navy"]End[/COLOR] With
Range("B2") = ""
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[seattletimebandit]

Mick,

Working like a champ! Not too worry about the back and forth. It only helped to F8 through the code to find the bust, then being able to explain what/where things were breaking. Great for learning to debug the code. I really tried to figure out where the problems were, but with my limited VBA chops, I had to break down and seek your advice.

Once again, many thanks. This will be a great tool for me.

Russell