VBA Match Data Back to Sheet1

[Stephen_IV]

I have about 150,000 rows of data. I have data on sheet 2. On Sheet 1 I have ID Numbers (All Unique). What I need to do is to match the data on Sheet 2 back to Sheet 1.

Sheet2 Example

<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>ID</th><th>Exit</th><th>Exit Code</th><th>Exit Comment</th></tr></thead><tbody>
<tr><td>1</td><td>10/12/2017</td><td>4</td><td>Lincoln University</td></tr>
<tr><td>1</td><td>9/18/2017</td><td>12</td><td>Washington charter school</td></tr>
<tr><td>1</td><td>9/6/2017</td><td>3</td><td>parent withdrew student moving to Virginia with dad</td></tr>
<tr><td>2</td><td>11/4/2017</td><td>1</td><td>Johnson School</td></tr>
<tr><td>2</td><td>9/16/2017</td><td>2</td><td>Moved to Franklin School</td></tr>
<tr><td>3</td><td>10/10/2017</td><td>2</td><td>Moved to Carver</td></tr>
</tbody></table>

Convert to this on Sheet 1

<table class="tableizer-table">
<thead><tr class="tableizer-firstrow"><th>ID</th><th>Exit</th><th>Exit Code</th><th>Exit Comment</th></tr></thead><tbody>
<tr><td>1</td><td>10/12/2017; 9/18/2017; 9/6/2017</td><td>4; 12; 3</td><td>Lincoln University; Washington charter school; parent withdrew student; moving to Virginia with dad</td></tr>
<tr><td>2</td><td>11/4/2017; 9/16/2017</td><td>1; 2</td><td>Johnson School; Moved to Franklin School</td></tr>
<tr><td>3</td><td>10/10/2017</td><td>2</td><td>Moved to Carver</td></tr>
</tbody></table>

 

[hiker95]

Stephen_IV,

If I understand you correctly, then, please try the following macro on a copy of your original workbook/worksheets.

Sub ReorganizeData()
' hiker95, 01/25/2018, ME1040653
Dim w2 As Worksheet, w1 As Worksheet
Dim a As Range, id As Range
Application.ScreenUpdating = False
Set w2 = Sheets("Sheet2")
Set w1 = Sheets("Sheet1")
With w2
  For Each a In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    Set id = w1.Columns(1).Find(a.Value, LookAt:=xlWhole)
    If Not id Is Nothing Then
      If w1.Cells(id.Row, 2) = vbEmpty Then
        w1.Cells(id.Row, 2).Value = a.Offset(, 1).Value
      Else
        w1.Cells(id.Row, 2).Value = w1.Cells(id.Row, 2).Value & "; " & a.Offset(, 1).Value
      End If
      If w1.Cells(id.Row, 3) = vbEmpty Then
        w1.Cells(id.Row, 3).Value = a.Offset(, 2).Value
      Else
        w1.Cells(id.Row, 3).Value = w1.Cells(id.Row, 3).Value & "; " & a.Offset(, 2).Value
      End If
      If w1.Cells(id.Row, 4) = vbEmpty Then
        w1.Cells(id.Row, 4).Value = a.Offset(, 3).Value
      Else
        w1.Cells(id.Row, 4).Value = w1.Cells(id.Row, 4).Value & "; " & a.Offset(, 3).Value
      End If
    End If
  Next a
  With w1
    .UsedRange.Columns.AutoFit
    .Activate
  End With
End With
Application.ScreenUpdating = True
End Sub

 

[Stephen_IV]

hiker95 thanks for the reply and your help. Your code works well on a small data set but on the large one seems to take a long time.

 

[hiker95]

hiker95 thanks for the reply and your help. Your code works well on a small data set but on the large one seems to take a long time.

Stephen_IV,

Thanks for the feedback.

You are welcome.


Maybe one of the Scripting.Dictionary Gurus will be able to come up with something faster.

 

[hiker95]

Stephen_IV,

The original macro on your original posted data set ran in 0.051 seconds.

Here is an updated/new macro that ran on your original posted data set in 0.016 seconds.

Sub ReorganizeData_V2()
' hiker95, 01/26/2018, ME1040653
Dim w2 As Worksheet, w1 As Worksheet
Dim a As Range, id As Range
Application.ScreenUpdating = False
Set w2 = Sheets("Sheet2")
Set w1 = Sheets("Sheet1")
With w2
  For Each a In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
    Set id = w1.Columns(1).Find(a.Value, LookAt:=xlWhole)
    If Not id Is Nothing Then
      If w1.Cells(id.Row, 2) = vbEmpty Then
        w1.Cells(id.Row, 2).Value = a.Offset(, 1).Value
      Else
        w1.Cells(id.Row, 2).Value = w1.Cells(id.Row, 2).Value & "; " & a.Offset(, 1).Value
      End If
      If w1.Cells(id.Row, 3) = vbEmpty Then
        w1.Cells(id.Row, 3).Value = a.Offset(, 2).Value
      Else
        w1.Cells(id.Row, 3).Value = w1.Cells(id.Row, 3).Value & "; " & a.Offset(, 2).Value
      End If
      If w1.Cells(id.Row, 4) = vbEmpty Then
        w1.Cells(id.Row, 4).Value = a.Offset(, 3).Value
      Else
        w1.Cells(id.Row, 4).Value = w1.Cells(id.Row, 4).Value & "; " & a.Offset(, 3).Value
      End If
    End If
  Next a
End With
With w1
  .UsedRange.Columns.AutoFit
  .Activate
End With
Application.ScreenUpdating = True
End Sub

 

[Stephen_IV]

hiker95, The 2nd post of code seems to go a lot faster. Thank you again for your time and thoughtfulness on this post! Thanks again! Have a great weekend!

 

[hiker95]

Stephen_IV,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.