VBA Create Unique Parent Child Relationship

B

Biz

Well-known Member
Joined
May 18, 2009
Messages
1,773
Office Version
  1. 2021
Platform
  1. Windows
Dear All

Parent in Column A and Child in B.

Sheet1 tab
<TABLE style="WIDTH: 96pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=128><COLGROUP><COL style="WIDTH: 48pt" span=2 width=64><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; WIDTH: 48pt; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" height=20 width=64>Parent</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; WIDTH: 48pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" width=64>Child</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" height=20 align=right>100</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" align=right>2</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" height=20 align=right>100</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" align=right>3</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" height=20 align=right>200</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" align=right>7</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" height=20 align=right>200</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" align=right>8</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" height=20></TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" align=right>9</TD></TR></TBODY></TABLE>

What vba code do I need to use to create Parent Child Relationship?
In our case above

Results tab
Parent Child
100 2,3
200 7,8
No Parent 9

Biz
 
Sort by date Sort by votes
Hi Hiker,

Thank you for fix.

It works very smooth.

Biz
 
Upvote 0

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Hi Hiker,

If I want to change blank to No Parent. I tried code below but if fails

Code: 
Sub Test()
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row

'Autofilter Criteria in for blanks
With ActiveSheet.Range("A1:C" & LR)
   .AutoFilter Field:=1, Criteria1:="=" 'Get Blanks
  On Error Resume Next
  .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"
  On Error GoTo 0
 .AutoFilter
End With
End Sub

How can I make it work?

Biz
 
Upvote 0
Biz,

You did not say what you wanted to do after you filtered column A for No Parent?


The following will filter column A for No Parent.


Code: 
Sub Test()
Dim LR As Long
'Dim LR2 As Long
'LR = Range("A" & Rows.Count).End(xlUp).Row
'LR2 = Range("B" & Rows.Count).End(xlUp).Row
'If LR2 > LR Then LR = LR2

LR = Cells.Find("*", , , , xlByRows, xlPrevious).Row

'Autofilter Criteria in for blanks
'If I want to change blank to No Parent.

With ActiveSheet.Range("A1:C" & LR)
   
   '.AutoFilter Field:=1, Criteria1:="=" 'Get Blanks
   .AutoFilter Field:=1, Criteria1:="=No Parent", Operator:=xlAnd
  
  On Error Resume Next

  '.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"

  On Error GoTo 0
 .AutoFilter
End With
End Sub
 
Upvote 0
Hi Hiker,

I was trying to use Test macro to filter on col A put No Parent

Code: 
Sub Test()
Dim LR As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
With ActiveSheet.Range("A1:A" & LR)
   
   '.AutoFilter Field:=1, Criteria1:="=" 'Get Blanks
   .AutoFilter Field:=1, Criteria1:="="
  
  On Error Resume Next
  .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"
  On Error GoTo 0
  .AutoFilter
End With
End Sub

Biz
 
Upvote 0
Biz,

Your current version of the Test macro:

Code: 
Sub Test()
Dim LR As Long
LR = Range("B" & Rows.Count).End(xlUp).Row
With ActiveSheet.Range("A1:A" & LR)
   
   '.AutoFilter Field:=1, Criteria1:="=" 'Get Blanks
   .AutoFilter Field:=1, Criteria1:="="
  
  On Error Resume Next
  .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"
  On Error GoTo 0
  .AutoFilter
End With
End Sub


This code will only work if there is a blank cell in column A, within the range A1:A_last_row_of_column_B
 
Upvote 0
Hi Hiker,

I have managed to modify my vba to incorporate your No Parent code. Your VBA was perfect but now probably pasting data in same worksheet tab.

Code: 
Sub MakeParentChild()
Dim LR As Long
Dim LR2 As Long
Dim aStartTime
aStartTime = Now()
LR = Range("A" & Rows.Count).End(xlUp).Row
LR2 = Range("B" & Rows.Count).End(xlUp).Row
 'Speeding Up VBA Code
    Application.ScreenUpdating = False 'Prevent screen flickering
    'Application.Calculation = False 'Preventing calculation
    Application.DisplayAlerts = False 'Turn OFF alerts
    Application.EnableEvents = False 'Prevent All Events
    Application.DisplayStatusBar = False
'Check for Child with No Parent Name and inser "No Parent"
With ActiveSheet.Range("A1:A" & LR2)
   .AutoFilter Field:=1, Criteria1:="=" ''Get Blanks
 
  On Error Resume Next
  .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"
  On Error GoTo 0
 
  .AutoFilter
End With
'Advanced Filter copy Unique Values
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1"), Unique:=True
'Define Headers
Range("F1") = "Child"
Range("G1") = "Sheet"
'Function MultipleVlookup
Range("F2:F" & LR + 1).Formula = "=IF(RC5="""","""",IF(ISNA(MultiLOOKUP(RC[-1],R1C1:R65000C1,2)),"""",MultiLOOKUP(RC[-1],R1C1:R65000C1,2)))"
Range("G2:G" & LR + 1).Formula = "=IF(RC5="""","""",IF(ISNA(MultiLOOKUP(RC[-2],R1C1:R65000C1,3)),"""",MultiLOOKUP(RC[-2],R1C1:R65000C1,3)))"
'Speeding Up VBA Code
    Application.ScreenUpdating = True 'Prevent screen flickering
    Application.Calculation = True 'Preventing calculation
    Application.DisplayAlerts = True 'Turn OFF alerts
    Application.EnableEvents = True 'Prevent All Events
    'Application.DisplayStatusBar = True
 
MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss"), vbInformation, "Process Time"
 
End Sub
 
 
Public Function MultiLOOKUP(lookup_value As Variant, table_array As Range, _
    col_index_num As Long) As Variant
 
    Application.Volatile (False)
    Dim Cell As Range
    Dim a, B
    a = ""
    MultiLOOKUP = CVErr(xlErrNA)
 
    Set table_array = Intersect(table_array, table_array.Parent.UsedRange)
    If table_array Is Nothing Then Exit Function
 
    For Each Cell In Union(table_array.Columns(1), table_array.Cells(1))
        If Cell = lookup_value Then
            If a <> "" Then
                a = a & ", " & Cell.Offset(0, col_index_num - 1)
            Else
           a = Cell.Offset(0, col_index_num - 1)
            End If
        End If
    Next Cell
        If a = "" Then MultiLOOKUP = ""
        MultiLOOKUP = a
 
    End Function

Thank you for your help.

Biz (y)
 
Upvote 0
Hi Hiker,

If I use my real data macro takes ages. You macro is very fast and efficient.

Sheet 1
<TABLE style="WIDTH: 112pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=149><COLGROUP><COL style="WIDTH: 65pt; mso-width-source: userset; mso-width-alt: 3181" width=87><COL style="WIDTH: 47pt; mso-width-source: userset; mso-width-alt: 2267" width=62><TBODY><TR style="HEIGHT: 51.75pt" height=69><TD style="BORDER-BOTTOM: windowtext 1pt solid; BORDER-LEFT: windowtext 1pt solid; BACKGROUND-COLOR: transparent; WIDTH: 65pt; HEIGHT: 51.75pt; BORDER-TOP: windowtext 1pt solid; BORDER-RIGHT: windowtext 1pt solid" class=xl66 height=69 width=87>Job Number</TD><TD style="BORDER-BOTTOM: windowtext 1pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 47pt; BORDER-TOP: windowtext 1pt solid; BORDER-RIGHT: windowtext 1pt solid" class=xl67 width=62>Co. 29
Correspond Job #
</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 12.75pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl68 height=17 align=right>381417</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl68 align=right>290711</TD></TR><TR style="HEIGHT: 12.75pt" height=17><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 12.75pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl68 height=17 align=right>381417</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl68 align=right>290711</TD></TR></TBODY></TABLE>

Results
<TABLE style="WIDTH: 116pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=154><COLGROUP><COL style="WIDTH: 38pt; mso-width-source: userset; mso-width-alt: 1828" width=50><COL style="WIDTH: 78pt; mso-width-source: userset; mso-width-alt: 3803" width=104><TBODY><TR style="HEIGHT: 15.75pt" height=21><TD style="BORDER-BOTTOM: windowtext 1pt solid; BORDER-LEFT: windowtext 1pt solid; BACKGROUND-COLOR: transparent; WIDTH: 38pt; HEIGHT: 15.75pt; BORDER-TOP: windowtext 1pt solid; BORDER-RIGHT: windowtext 1pt solid" class=xl66 height=21 width=50>Parent</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; WIDTH: 78pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" width=104>Child</TD></TR><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; HEIGHT: 15pt; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl67 height=20 align=right>381417</TD><TD style="BORDER-BOTTOM: #f0f0f0; BORDER-LEFT: #f0f0f0; BACKGROUND-COLOR: transparent; BORDER-TOP: #f0f0f0; BORDER-RIGHT: #f0f0f0" class=xl68 align=right>290,711,290,711</TD></TR></TBODY></TABLE>

Vba fails to put "," when there is duplicate.
Should be

Parent Child
381417 290711,290711

Your help would be appreciated.

Biz
 
Upvote 0
Biz,

In the future when you are requsting help to solve a problem, you should supply the following:

What version of Excel are you using?

Please attach screenshots of your workbook or a sample workbook that accurately portrays your current workbook on one sheet, and what it should look like 'After' on another sheet.

This makes it much easier to see exactly what you want to do, as well as shows us whether there is a consistent number of rows between tables and such.

Here are three possible ways to post small (copyable) screen shots directly in your post:

Please post a screenshot of your sheet(s), what you have and what you expect to achieve, with Excel Jeanie HTML 4 (contains graphic instructions).
http://www.excel-jeanie-html.de/html/hlp_schnell_en.php

or
RichardSchollar’s beta HTML Maker -...his signature block at the bottom of his post

or
Borders-Copy-Paste


If you are not able to give us screenshots:

To get the most precise answer, it is best to upload/attach a sample workbook (sensitive data scrubbed/removed) that contains an example of your raw data on one worksheet, and on another worksheet your desired results.

The structure and data types of the sample workbook must exactly duplicate the real workbook. Include a clear and explicit explanation of your requirements.

You can upload your workbook to www.box.net and provide us with a link to your workbook.



Sample NEW raw data in worksheet Sheet1:


Excel Workbook
AB
1Job NumberCo. 29Correspond Job #
2381417290711
3381417290711
4
Sheet1





After the latest update to the macro:


Excel Workbook
AB
1ParentChild
2381417290711,290711
3
Results





Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).


Rich (BB code): 
Option Explicit
Sub ParentChildV3()
' hiker95, 02/10/2011
' http://www.mrexcel.com/forum/showthread.php?t=527943
Dim w1 As Worksheet, wR As Worksheet
Dim LR As Long, LR2 As Long, a As Long, aa As Long, SR As Long, ER As Long, H As String
Application.ScreenUpdating = False
Set w1 = Worksheets("Sheet1")
LR = w1.Cells(Rows.Count, 1).End(xlUp).Row
LR2 = w1.Cells(Rows.Count, 2).End(xlUp).Row
If LR2 > LR Then LR = LR2
With w1.Range("A1:A" & LR)
  .AutoFilter Field:=1, Criteria1:="="
  On Error Resume Next
  .Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"
  On Error GoTo 0
  .AutoFilter
End With
w1.Range("A2:B" & LR).Sort Key1:=w1.Range("A2"), Order1:=xlAscending, Key2:=w1.Range("B2") _
  , Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
  Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wR = Worksheets("Results")
wR.UsedRange.Clear
w1.Columns(1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wR.Columns(1), Unique:=True
wR.Range("A1:B1") = [{"Parent","Child"}]
LR = wR.Cells(Rows.Count, 1).End(xlUp).Row
For a = 2 To LR Step 1
  H = ""
  SR = Application.Match(wR.Cells(a, 1), w1.Columns(1), 0)
  ER = Application.Match(wR.Cells(a, 1), w1.Columns(1), 1)
  For aa = SR To ER Step 1
    H = H & w1.Cells(aa, 2) & ","
  Next aa
  If Right(H, 1) = "," Then H = Left(H, Len(H) - 1)
  
  With wR.Cells(a, 2)
    .NumberFormat = "@"
    .Value = H
  End With  

Next a
wR.UsedRange.Columns.AutoFit
wR.Activate
Application.ScreenUpdating = True
End Sub


Then run the ParentChildV3 macro.
 
Upvote 0
Hi Hiker,
New code is perfect. Thank you again for your help.
I will try use better countdown sample and mention Excel version too.
Sorry for any inconvenience.

I never knew it was possible
Code: 
wR.Range("A1:B1") = [{"Parent","Child"}]
Code: 
.Offset(1).Resize(.Rows.Count - 1).SpecialCells(12).Value = "No Parent"

Biz
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Using Excel formula to create HTML code text referencing specific cells
Replies
0
Views
817
gvsumich
G
A
  • Question
VBA - Automatically Break the Line in HTML format.
Replies
7
Views
1K
Attrazion
A
C
  • Solved
Excel 2016 32bit VBA Pulling info from Website to Sheet
Replies
2
Views
1K
CrashOD
C
E
  • Question
Adding a custom message.
Replies
1
Views
422
Micron
M
D
  • Question
Problems Encountered When Generating VBA Excel Charts with 15-Minute Interval Data.
Replies
0
Views
141
dilshod_k
D

Forum statistics

Threads
1,214,653
Messages
6,120,751
Members
448,989
Latest member
mariah3

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