Create Smaller Tables From Larger Source Data Table - VBA

S

seattletimebandit

Board Regular
Joined
Apr 11, 2013
Messages
69
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:
[TABLE="class: grid, width: 669"]
<tbody>[TR]
[TD] [Cell B2][/TD]
[TD]322-H7[/TD]
[TD]323-H7[/TD]
[TD]324-G8[/TD]
[TD]325-C11[/TD]
[TD]326-E10[/TD]
[TD]327-E10[/TD]
[/TR]
[TR]
[TD]Benzene[/TD]
[TD]0.00829 U[/TD]
[TD]0.00717 U[/TD]
[TD]0.00806 U[/TD]
[TD]0.0077 U[/TD]
[TD]0.0082 U[/TD]
[TD]0.00797 U[/TD]
[/TR]
[TR]
[TD]Toluene[/TD]
[TD]0.0237 U[/TD]
[TD]0.0205 U[/TD]
[TD]0.0231 U[/TD]
[TD]0.022 U[/TD]
[TD]0.0235 U[/TD]
[TD]0.0228 U[/TD]
[/TR]
[TR]
[TD]Ethylbenzene[/TD]
[TD]0.0297 U[/TD]
[TD]0.0257 U[/TD]
[TD]0.0288 U[/TD]
[TD]0.0276 U[/TD]
[TD]0.0293 U[/TD]
[TD]0.0285 U[/TD]
[/TR]
[TR]
[TD]mp-Xylene[/TD]
[TD]0.0593 U[/TD]
[TD]0.0513 U[/TD]
[TD]0.0577 U[/TD]
[TD]0.0551 U[/TD]
[TD]0.0587 U[/TD]
[TD]0.0571 U[/TD]
[/TR]
[TR]
[TD]o-Xylene[/TD]
[TD]0.0297 U[/TD]
[TD]0.0257 U[/TD]
[TD]0.0288 U[/TD]
[TD]0.0276 U[/TD]
[TD]0.0293 U[/TD]
[TD]0.0285 U[/TD]
[/TR]
[TR]
[TD]Gasoline[/TD]
[TD]5.93 U[/TD]
[TD]5.13 U[/TD]
[TD]5.77 U[/TD]
[TD]5.51 U[/TD]
[TD]5.87 U[/TD]
[TD]5.71 U[/TD]
[/TR]
</tbody>[/TABLE]

Smaller tables output, can start one row down from source table for spacing(Note the column header moves to the left in Column B):
[TABLE="class: grid, width: 204"]
<tbody>[TR]
[TD]322-H7[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Benzene[/TD]
[TD]0.00829 U[/TD]
[/TR]
[TR]
[TD]Toluene[/TD]
[TD]0.0237 U[/TD]
[/TR]
[TR]
[TD]Ethylbenzene[/TD]
[TD]0.0297 U[/TD]
[/TR]
[TR]
[TD]mp-Xylene[/TD]
[TD]0.0593 U[/TD]
[/TR]
[TR]
[TD]o-Xylene[/TD]
[TD]0.0297 U[/TD]
[/TR]
[TR]
[TD]Gasoline[/TD]
[TD]5.93 U[/TD]
[/TR]
</tbody>[/TABLE]




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
 
Sort by date Sort by votes
MickG,

Is there a way to preserve the format of the source table cells? Some of the data may be bold, some may be bold and shaded, some may have no bold/shade.

I've been trying to figure out how to return .Format with the Offset property as you did with returning the .Value of each cell.

Brain...hurts...

Russell
 
Upvote 0

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG20Oct20
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Lst = Cells("2", Columns.Count).End(xlToLeft).Column - 2
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2", Range("B2").End(xlDown))
[COLOR="Navy"]For[/COLOR] Ac = 1 To Lst
    Rw = Rw + Rng.Count + 1
    Rng.Copy Rng.Offset(Rw).Resize(Rng.Count)
    Rng.Offset(, Ac).Copy Rng.Offset(Rw, 1).Resize(Rng.Count)
    Rng.Offset(Rw)(1).Resize(, 2).BorderAround Weight:=xlThick
    Rng(1).Offset(Rw).Value = Rng(1).Offset(Rw, 1).Value
    Rng.Offset(Rw + 1, 1).Resize(Rng.Count - 1).BorderAround Weight:=xlThick
    Rng(1).Offset(Rw, 1).Value = ""
[COLOR="Navy"]Next[/COLOR] Ac

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
MickG-

Nicely done! That works perfect for keeping the bold/shading and making the individual tables, BUT...

The previous version put a border around the top row cells (no vertical border between cells), a border around the data (both columns), but no inside horizontal borders and only the one vertical inside border.

The new code adds an entire border grid. I assume because we are asking for formatting each cell, and the source table has the entire border grid, which makes perfect sense. Is it possible to re-do the borders in the output tables to match the previous code version?

-Russell
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG21Oct19
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Ac [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Lst [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
Lst = Cells("2", Columns.Count).End(xlToLeft).Column - 2
[COLOR="Navy"]Set[/COLOR] Rng = Range("B2", Range("B2").End(xlDown))
[COLOR="Navy"]For[/COLOR] Ac = 1 To Lst
    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 + 1).Resize(Rng.Count - 1).BorderAround Weight:=xlThick

    Rng.Offset(, Ac).Copy Rng.Offset(Rw, 1).Resize(Rng.Count)
    Rng.Offset(Rw, 1).Resize(Rng.Count).Borders.LineStyle = xlNone
    Rng.Offset(Rw + 1, 1).Resize(Rng.Count - 1).BorderAround Weight:=xlThick
    
    Rng.Offset(Rw)(1).Resize(, 2).BorderAround Weight:=xlThick
    Rng(1).Offset(Rw).Value = Rng(1).Offset(Rw, 1).Value
    Rng(1).Offset(Rw, 1).Value = ""
[COLOR="Navy"]Next[/COLOR] Ac
Application.ScreenUpdating = True

[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick-

Of course! Copy all the formatted/values of the cells, then remove all borders, and then add the borders I need. *dope slap to forehead*. Thanks for that lesson!

Thanks again. Can't wait to share this with my co-worker. And as always I send the module with a big kudos to you as the coder [and anyone else that may jump in with advice]. I only take credit for the tiniest of tweaks, and the ability to ask the questions that makes sense [hopefully] to the forum as to my end goal.

One tweak I made was to add this at the end of the For statement to align the data in the header of the smaller tables to the left.

Code: 
With Rng(1).Offset(Rw).Cells
    .HorizontalAlignment = xlLeft
    End With


Again many thanks.

-Russell
 
Upvote 0
Mick,

There was one other thing I've been working on. With help from Fluff, I was able to take data from the top row of cells that have the same sample ID, but with a different set of characters on the right of the second dash "-":

GP-1-2.5 GP-1-10 GP-1-15 GP-2-5 GP-2-15 GP-2-20 etc.

Fluff's code does this, separates each Sample ID (GP-1 then GP-2) from the depth the sample was collected (2.5, 10, 15) and removes the right- most dash:

Code: 
Sub SplitDepthsFromSampleID()
  Dim ID As String
  Dim rng As Range
  
  Set rng = Application.InputBox("Please select the range", Default:="$A$1", Type:=8)
  ID = Left(rng.Resize(1, 1), InStrRev(rng.Resize(1, 1), "-") - 1)
  rng.Offset(, -1).Resize(1, 1) = ID
  rng.Replace ID & "-", "", xlPart, , , , False
End Sub

I was trying to figure out how to combine the code you presented in this thread to create the smaller tables, but be able to look at the source table's first row, grab all the sample ID's that have the same ID (GP-1 then GP-2, then GP-3, etc.). So each smaller table generated by the code you wrote, but clearly there is an array needed or Scripting.Dictionary or something to make this happen. Thoughts?







[table="width: 500, class: Grid"]
[tr]
[td][/td]
[td]GP-1-2.5[/td]
[td]GP-1-10[/td]
[td]GP-1-15[/td]
[td]GP-2-5[/td]
[td]GP-2-15[/td]
[td]GP-2-20[/td]
[/tr]
[tr]
[td]Benzene[/td]
[td]0.5[/td]
[td]15[/td]
[td]0.02[/td]
[td]9.0[/td]
[td]12[/td]
[td]19[/td]

[/tr]
[tr]
[td]Toluene[/td]
[td]17[/td]
[td]522[/td]
[td]548[/td]
[td]2,991[/td]
[td]145[/td]
[td]561[/td]

[/tr]
[tr]
[td]Ethylbenzene[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[/tr]
[tr]
[td]mp-Xylene[/td]
[td]15[/td]
[td]17.5[/td]
[td]23.9[/td]
[td]0.2U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[/tr]
[tr]
[td]o-Xylene[/td]
[td]151[/td]
[td]147.5[/td]
[td]213.9[/td]
[td]0.2U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[/tr]
[/table]

[table="width: 500, class: Grid"]
[tr]
[td]GP-1[/td]
[td]2.5[/td]
[td]10[/td]
[td]15[/td]

[/tr]
[tr]
[td]Benzene[/td]
[td]0.5[/td]
[td]15[/td]
[td]0.02[/td]

[/tr]
[tr]
[td]Toluene[/td]
[td]17[/td]
[td]522[/td]
[td]548[/td]

[/tr]
[tr]
[td]Ethylbenzene[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]

[/tr]
[tr]
[td]mp-Xylene[/td]
[td]15[/td]
[td]17.5[/td]
[td]23.9[/td]

[/tr]
[tr]
[td]o-Xylene[/td]
[td]151[/td]
[td]147.5[/td]
[td]213.9[/td]

[/tr]
[/table]

[table="width: 500, class: Grid"]
[tr]
[td]GP-2[/td]
[td]5[/td]
[td]15[/td]
[td]20[/td]

[/tr]
[tr]
[td]Benzene[/td]

[td]9.0[/td]
[td]12[/td]
[td]19[/td]
[/tr]
[tr]
[td]Toluene[/td]

[td]2,991[/td]
[td]145[/td]
[td]561[/td]
[/tr]
[tr]
[td]Ethylbenzene[/td]

[td]0.2 U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[/tr]
[tr]
[td]mp-Xylene[/td]

[td]0.2U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[/tr]
[tr]
[td]o-Xylene[/td]

[td]0.2U[/td]
[td]0.2 U[/td]
[td]0.2 U[/td]
[/tr]
[/table]
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG30Oct58
[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]
[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(, Ac).Resize(, col).Copy Rng.Offset(Rw, 1)
    Rng(1).Offset(Rw) = K
    Rng(1).Offset(Rw, 1).Resize(, col) = Split(.Item(K), ",")
    Ac = Ac + col
[COLOR="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
Range("B2") = ""
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
Mick,

That works beautifully! Thanks a ton!

I've been trying to format the borders like the beginning of this thread with the table cells that were not split, however, I'm bumping up against an issue of looping through nth-columns. I did add the bits indented and commented with "jrs...". It works, but is limited to the actual cell/row references.

Code: 
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             'jrs - Remove border grid from first column
        Rng.Offset(Rw + 1).Resize(Rng.Count - 1).BorderAround Weight:=xlThin    'jrs - Add border around compounds in first column
    Rng.Offset(, Ac).Resize(, col).Copy Rng.Offset(Rw, 1)
        Rng.Offset(Rw, 1).Resize(Rng.Count).Borders.LineStyle = xlNone          'jrs - Remove borders from first data column (Col C) ***THIS IS WERE I NEED TO LOOP THROUGH TO LAST Nth-COLUMN***
    Rng(1).Offset(Rw) = K
    Rng(1).Offset(Rw, 1).Resize(, col) = Split(.Item(K), ",")
        Rng.Offset(Rw)(1).Resize(, 1).BorderAround Weight:=xlThin               'jrs - Add border around Sample ID cell in Col B [first cell in each small table]
        Rng.Offset(Rw)(1).Resize(, 2).BorderAround Weight:=xlThin               'jrs - Add border around first depth cell (Col C) ***THIS IS WERE I NEED TO LOOP THROUGH TO LAST Nth-COLUMN***
        Rng.Offset(Rw + 1, 1).Resize(Rng.Count - 1).BorderAround Weight:=xlThin 'jrs - Add border around first depth column (Col C) ***THIS IS WERE I NEED TO LOOP THROUGH TO LAST Nth-COLUMN***
                      
    Ac = Ac + col
    
Next K

Following the code you provided, I placed the lines of code for removal/adding borders. Of course it will only go as far formatting the first and second columns. I just couldn't figure out how to loop through each additional column.

Note that one other formatting needed is the top row from Col C to the end of columns has no Interior vertical border lines. The depth numbers just float out there with no separating border.
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG01Nov23
[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:=xlThick
    Rng.Offset(Rw)(1).BorderAround Weight:=xlThick
    
    Rng.Offset(, Ac).Resize(, col).Copy Rng.Offset(Rw, 1)
    Rng.Offset(Rw, Ac).Resize(Rng.Count, col).Borders.LineStyle = xlNone
    [COLOR="Navy"]For[/COLOR] Hoz = 1 To col
        Rng.Offset(Rw, Hoz).BorderAround Weight:=xlThick
        Rng.Offset(Rw, Hoz)(1).BorderAround Weight:=xlThick
    [COLOR="Navy"]Next[/COLOR] Hoz
    
    [COLOR="Navy"]For[/COLOR] Hoz = 1 To col - 1
        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="Navy"]Next[/COLOR] K
[COLOR="Navy"]End[/COLOR] With
Range("B2") = ""
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Splitting data in cells w/VBA macro
Replies
2
Views
712
seattletimebandit
S
L
  • Question Question
VBA - Help with Copy/Paste from Source Workbook to Create Multiple Rows in Active Workbook
Replies
2
Views
283
Luannilow
L
S
  • Question Question
Data Extraction from a single large table with formulae or VBA (VLOOKUP? MATCH? INDEX)
2
Replies
11
Views
2K
Aladin Akyurek
Aladin Akyurek
S
  • Question Question
Transpose data as an array in vba
2 3
Replies
25
Views
7K
seattletimebandit
S

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top