VBA: 'pair matching' 2 closest match 2 companies from 2 datasets based on size, industry+

[samuk1000]

Hello coders and VBA gurus,

now crossposted here: http://www.excelforum.com/excel-prog...-industry.html (stated as rule ask to admit cross-posting) -reason due to no response and now on 4/5th page.

Your help is much appreciated and urgently requested about the below.

I have the following piece of code which did the job I want to do on another dataset. Unfortunately I do not have the original dataset.

What I think this program is supposed to do roughly is:

= Find the closest matching pair of companies from two datasets/worksheets
= According to firstly SIZE (Asset)
= Then INDUSTRY (as represented by the 'SIC' code)
= Then other variables (as desired) - in my sample case the variables I want to match on are: a001000000(size); incd (industry code); roa mbr; dar in that order
= So that you are left with a dataset with a sample of the firms from each of the two original datasets, in pairs, so that they are closely matched in terms of all but the separating variable that separates the two datasets (i.e. in the case below "Chinese" or "US")

How can I implement the code provided to do as above but using my sample, for example?

I include a sample of my own data. My problem is what do I need to change in the code (or my own dataset) in order to be able to run this program using my own dataset.

Here is the code:

Function distance(chi1, chi2, us1, us2)
    distance = 0.1 * Abs(us1 / chi1 - 1) + 0.9 * Abs(us2 / chi2 - 1)

End Function

Sub DAMatch() 'Asset+ROA 3 digits

    
Dim i, j, k, l, m, t, Num As Integer
Dim n As Integer
n = 3
Dim ind As String

ReDim ChPrio(0, 0, 3) As Variant

ReDim Chfirm(20, 0) As Variant
ReDim Indfirm(20, 0) As Variant

'We must rank the data by sic and cik first !!!!
Worksheets("China").Activate
Columns("W:CD").Select
    Selection.ClearContents


For i = 2 To 211
Worksheets("China").Activate

ReDim Chfirm(20, 0) As Variant
ReDim Indfirm(20, 0) As Variant
ind = Left(Cells(i, 3), 2)

    Do While Left(Cells(i, 3), 2) = ind
    
                   ReDim Preserve Chfirm(20, UBound(Chfirm, 2) + 1)
                   For k = 1 To 20
                       Chfirm(k, UBound(Chfirm, 2)) = Cells(i, k)
                   Next k
                   
                   i = i + 1
    Loop
    i = i - 1
 

    Worksheets("US").Activate
    

    
    j = 2 ' us firms
       
       Do While Left(Cells(j, 3), 2) <> ind And Cells(j, 3) <> "" 'find the first firm in this industry
            j = j + 1
       Loop
           If Left(Cells(j, 3), 2) = ind Then
                Do While Left(Cells(j, 3), 2) = ind
                    If Cells(j, 4) <> "" And Cells(j, 6) <> "" Then  'the distance can be calculated
                        ReDim Preserve Indfirm(20, UBound(Indfirm, 2) + 1)
                        For k = 1 To 20
                            Indfirm(k, UBound(Indfirm, 2)) = Cells(j, k)
                        Next k
                    End If
                    j = j + 1
                Loop
           End If
       
 
 Worksheets("China").Activate
 
 ReDim ChPrio(UBound(Chfirm, 2), UBound(Indfirm, 2), 3) As Variant
 For j = 1 To UBound(Chfirm, 2)
    ChPrio(j, 0, 1) = Chfirm(1, j) 'label of CHN firms
    If Chfirm(4, j) <> "" And Chfirm(6, j) <> "" Then 'distance can be calculated
        For k = 1 To UBound(Indfirm, 2)
            'If Indfirm(4, k) <> "" And Indfirm(6, k) <> "" Then
                ChPrio(j, k, 1) = Indfirm(1, k)
                ChPrio(j, k, 2) = distance(Chfirm(4, j), Chfirm(6, j), Indfirm(4, k), Indfirm(6, k))
                ChPrio(j, k, 3) = k
            'End If
        Next k
    End If
 Next j
 
    For j = 1 To UBound(Chfirm, 2) 'rank the matching firms
        ReDim temp(1, 3) As Variant
        For k = 1 To UBound(ChPrio, 2) - 1 'mao pao
                
                            For m = k + 1 To UBound(ChPrio, 2)
                                If ChPrio(j, m, 2) < ChPrio(j, k, 2) Then
                                  temp(1, 1) = ChPrio(j, k, 1)
                                  temp(1, 2) = ChPrio(j, k, 2)
                                  temp(1, 3) = ChPrio(j, k, 3)
                                  ChPrio(j, k, 1) = ChPrio(j, m, 1)
                                  ChPrio(j, k, 2) = ChPrio(j, m, 2)
                                  ChPrio(j, k, 3) = ChPrio(j, m, 3)
                                  ChPrio(j, m, 1) = temp(1, 1)
                                  ChPrio(j, m, 2) = temp(1, 2)
                                  ChPrio(j, m, 3) = temp(1, 3)
                                End If
                            Next m
        Next k
 
    Next j
 
 
ReDim Chtemp(UBound(Chfirm, 2), n, 3) As Variant
ReDim Indtemp(UBound(Indfirm, 2), 3) As Variant

    If UBound(ChPrio, 2) > 0 Then 'If there are available us firms
    
           For j = 1 To UBound(Chfirm, 2)
              If ChPrio(j, 1, 1) <> "" Then
                    For k = 1 To n 'initialize
                        For l = 1 To 3
                            Chtemp(j, k, l) = ""
                        Next l
                    Next k
                    
                    m = 1 ' the number of matching firms
                    For k = 1 To UBound(Indfirm, 2)
                        
                                Num = ChPrio(j, k, 3)  'firm j's kth preference
                        
                        If Indtemp(Num, 2) = "" Then 'available
                            Indtemp(Num, 1) = ChPrio(j, 0, 1)
                            Indtemp(Num, 2) = ChPrio(j, k, 2)
                            Indtemp(Num, 3) = j
                            Chtemp(j, m, 1) = ChPrio(j, k, 1)
                            Chtemp(j, m, 2) = ChPrio(j, k, 2)
                            Chtemp(j, m, 3) = ChPrio(j, k, 3)
                            m = m + 1
                        ElseIf ChPrio(j, k, 2) < Indtemp(Num, 2) And Indtemp(Num, 2) <> "" Then 'gain priority
                            t = Indtemp(Num, 3)
                            Indtemp(Num, 1) = ChPrio(j, 0, 1)
                            Indtemp(Num, 2) = ChPrio(j, k, 2)
                            Indtemp(Num, 3) = j
                            Chtemp(j, m, 1) = ChPrio(j, k, 1)
                            Chtemp(j, m, 2) = ChPrio(j, k, 2)
                            Chtemp(j, m, 3) = ChPrio(j, k, 3)
                            m = m + 1
                            
                            If t < j Then 'jump back
                                j = t - 1
                                Exit For
                            End If
                         ElseIf ChPrio(j, k, 2) = Indtemp(Num, 2) And Indtemp(Num, 2) <> "" Then ' itself
                            Chtemp(j, m, 1) = ChPrio(j, k, 1)
                            Chtemp(j, m, 2) = ChPrio(j, k, 2)
                            Chtemp(j, m, 3) = ChPrio(j, k, 3)
                            m = m + 1
                        End If
                        If m > n Then Exit For 'the number is enough
                    Next k
              End If
           Next j
    
                For j = i - UBound(Chfirm, 2) + 1 To i 'out print
                    For k = 1 To Application.WorksheetFunction.Min(n, UBound(Indfirm, 2))
                        If Chtemp(j - i + UBound(Chfirm, 2), k, 3) <> "" Then  'if there is a matching firm there
                            For t = 1 To 20
                                Cells(j, 22 + 20 * (k - 1) + t) = Indfirm(t, Chtemp(j - i + UBound(Chfirm, 2), k, 3))
                            Next t
                        End If
                    Next k
                Next j
    End If
Next i
End Sub