Filter and merging data

Elliottj2121

New Member
Joined
Apr 15, 2021
Messages
15
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hello I am wondering if someone could help me filter and merge two data sets. I have an ongoing workbook that I add data to every week from a different workbook. I have written some code already to copy the data from one workbook to the working workbook and format it the way I want it. However, I don't know how to further format, filter and merge the two data sets. I attached screenshots of what I am trying to do. I am looking for additional coding to have it look in column C and if two values match copy the corresponding value in columns A and E.

VBA Code:
Sub MasterARdue45()
    Call OpenWkbWorkingArdue45
    Call Ardue45formatting
    Call CopyData
End Sub

Option Explicit
Sub OpenWkbWorkingArdue45()
Dim sPath As String

    sPath = Environ("USERPROFILE") & "\Desktop\WorkingARdue45.xlsx"
    Workbooks.Open Filename:=sPath
End Sub

Sub Ardue45formatting()

With Workbooks("Ardue45.xls").Worksheets(1)
    Range("A2:A500").Select
    Selection.ClearContents
    Columns("I:I").ColumnWidth = 16.14
    Columns("C:C").ColumnWidth = 12.29
    Columns("C:C").ColumnWidth = 15.71
    Columns("C:C").ColumnWidth = 18.29
    Columns("B:B").ColumnWidth = 15.86
    Columns("A:I").Select
    Selection.AutoFilter
    Range("D13").Select
End With
    
With ActiveSheet
    For Each cell In .Range("A1:" & .Range("A1").End(xlDown).Address)
        If .Cells(cell.Row, 7).Value > 0 Then
            cell.EntireRow.Font.Bold = True
        End If
    Next
End With

End Sub

Sub CopyData()

Dim wbCopy As Worksheet
    Dim wbDest As Worksheet
    Dim lr As Long
    Dim lrTarget As Long
    Set wbCopy = Workbooks("Ardue45.xlsx").Worksheets(1)
    Set wbDest = Workbooks("WorkingARdue45.xlsx").Worksheets(1)

    
    wbCopy.Activate
    Sheets(1).Select
    lr = wbCopy.Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    Range("A2:I" & lr).Copy
    
    wbDest.Activate
    Sheets(1).Select
    lrTarget = wbDest.Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
    Cells(lrTarget + 2, 1).Select
    ActiveSheet.Paste
    Cells(1, 1).Select

End Sub
VBA Code:
[/CODE]
[/CODE]




The first image below is how my data looks with the code above. The first two rows are old data and the remaining rows are the new data. The second image is how I would like it to look. Basically copying any data in columns A and E from the old data set and paste it into the new data set if there is a duplicate value in column C.

1619811481485.png



1619811562016.png
 

Elliottj2121

New Member
Joined
Apr 15, 2021
Messages
15
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Working on this. In your CopyData routine you do a Find for "*" in formulas both in the wbCopy and the wbDest. Based on the images above the Find won't return anything. Can you help me understand this? Also, which workbook contains the VBA code?
Thank you! The VBA code is in my "personal.xlbs". Since the Ardue45 workbook is exported data from Showcase Query, it's a new workbook everytime the query is ran from the database. I figured keeping the VBA code there would be best because of that fact.
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

vw412

Active Member
Joined
Dec 16, 2011
Messages
343
Office Version
  1. 2019
  2. 2016
  3. 2010
  4. 2007
Platform
  1. Windows
Ok. I will work from that stand point.
 

vw412

Active Member
Joined
Dec 16, 2011
Messages
343
Office Version
  1. 2019
  2. 2016
  3. 2010
  4. 2007
Platform
  1. Windows
I have something working for you. I took your code and reworked it and added the merge routine. Here it is:
VBA Code:
Option Explicit

Sub MasterARdue45()
  Dim wbARDue45 As Workbook, wbWorkingARDue45 As Workbook
  Set wbARDue45 = OpenWkbARDue45
  Set wbWorkingARDue45 = OpenWkbWorkingARDue45
  Ardue45formatting wbARDue45
'  CopyData wbARDue45, wbWorkingARDue45
  MergeData wbARDue45, wbWorkingARDue45
  WorkingArdue45formatting wbWorkingARDue45
End Sub

Function OpenWkbWorkingARDue45() As Workbook
  Dim sPath As String, sName As String
  sName = "WorkingARdue45.xlsx"
  sPath = Environ("USERPROFILE") & "\Desktop\" & sName
  Set OpenWkbWorkingARDue45 = Workbooks.Open(Filename:=sPath)
End Function
Function OpenWkbARDue45() As Workbook
  Dim sPath As String, sName As String
  sName = "ARdue45.xlsx"
  sPath = Environ("USERPROFILE") & "\Desktop\" & sName
  Set OpenWkbARDue45 = Workbooks.Open(Filename:=sPath)
End Function

Sub Ardue45formatting(wkb As Workbook)
  Dim r As Variant
  With wkb.Worksheets(1)
    .Range("A2:A500").ClearContents
    .Columns("I:I").ColumnWidth = 16.14
    .Columns("C:C").ColumnWidth = 18.29
    .Columns("B:B").ColumnWidth = 15.86
    .Columns("A:I").AutoFilter
    For r = 2 To LastRow(wkb.Worksheets(1)) ' In .Range("A1:" & .Range("A1").End(xlDown).Address)
      If .Cells(r, 7).Value > 0 Then
        .Rows(r).EntireRow.Font.Bold = True
      End If
    Next
  End With
End Sub
Sub WorkingArdue45formatting(wkb As Workbook)
  Dim r As Variant
  With wkb.Worksheets(1)
    .Range("A2:A500").ClearContents
    .Columns("I:I").ColumnWidth = 16.14
    .Columns("C:C").ColumnWidth = 18.29
    .Columns("B:B").ColumnWidth = 15.86
    .Columns("A:I").AutoFilter
    For r = 2 To LastRow(wkb.Worksheets(1)) ' In .Range("A1:" & .Range("A1").End(xlDown).Address)
      If .Cells(r, 7).Value > 0 Then
        .Rows(r).EntireRow.Font.Bold = True
      End If
    Next
  End With
End Sub

Sub CopyData(wkbFrom As Workbook, wkbTo As Workbook)
  Dim wsFrom As Worksheet, wsTo As Worksheet
  Dim lr As Variant, lrTarget As Variant
  Set wsFrom = wkbFrom.Worksheets(1)
  Set wsTo = wkbTo.Worksheets(1)
  lr = LastRow(wsFrom)
  If lr > 0 Then
    lrTarget = LastRow(wsTo)
    If lrTarget > 0 Then
      wsFrom.Range("A2:I" & lr).Copy wsTo.Cells(lrTarget + 2, 1)
    End If
  End If
End Sub

Sub MergeData(wkbFrom As Workbook, wkbTo As Workbook)
  Dim wsFrom As Worksheet, wsTo As Worksheet, CrntIDs As Scripting.Dictionary
  Dim lFromRow As Variant, lToRow As Variant, r As Long, i As Long
  Set wsFrom = wkbFrom.Worksheets(1)
  Set wsTo = wkbTo.Worksheets(1)
  lToRow = LastRow(wsTo)
  If lToRow > 0 Then
    ' collect Customer Numbers in To file for matching to incoming records
    Set CrntIDs = New Dictionary
    For r = 2 To lToRow
      CrntIDs.Add CStr(wsTo.Cells(r, 3).Value), r
    Next r
  End If
  lFromRow = LastRow(wsFrom)
  If lFromRow > 0 Then
    For r = 2 To lFromRow
      If CrntIDs.Exists(CStr(wsFrom.Cells(r, 3).Value)) Then
        ' matched customer ids so copy part of record
        i = CrntIDs(CStr(wsFrom.Cells(r, 3).Value))
        wsFrom.Range("A" & r & ":D" & r).Copy wsTo.Cells(i, 1)
        wsFrom.Range("F" & r & ":I" & r).Copy wsTo.Cells(i, 6)
      Else
        ' no match of customer id so copy entire record and increment record count
        wsFrom.Range("A" & r & ":I" & r).Copy wsTo.Cells(lToRow + 1, 1)
        lToRow = lToRow + 1
      End If
    Next r
  End If
End Sub

Function LastRow(sh As Worksheet) As Variant
  On Error Resume Next
  LastRow = sh.Cells.Find(What:="*", _
                          After:=sh.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
  On Error GoTo 0
End Function
Function LastColumn(sh As Worksheet) As Variant
  On Error Resume Next
  LastColumn = sh.Cells.Find(What:="*", _
                             After:=sh.Range("A1"), _
                             Lookat:=xlPart, _
                             LookIn:=xlFormulas, _
                             SearchOrder:=xlByColumns, _
                             SearchDirection:=xlPrevious, _
                             MatchCase:=False).Column
  On Error GoTo 0
End Function

Lots to talk about here but check it out and then ask me some questions so I can help you understand what I did and why.
 
Solution

Elliottj2121

New Member
Joined
Apr 15, 2021
Messages
15
Office Version
  1. 365
  2. 2019
Platform
  1. Windows

ADVERTISEMENT

Thank you! This seems to work as its supposed to! Thank you again!
 

Elliottj2121

New Member
Joined
Apr 15, 2021
Messages
15
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I have something working for you. I took your code and reworked it and added the merge routine. Here it is:
VBA Code:
Option Explicit

Sub MasterARdue45()
  Dim wbARDue45 As Workbook, wbWorkingARDue45 As Workbook
  Set wbARDue45 = OpenWkbARDue45
  Set wbWorkingARDue45 = OpenWkbWorkingARDue45
  Ardue45formatting wbARDue45
'  CopyData wbARDue45, wbWorkingARDue45
  MergeData wbARDue45, wbWorkingARDue45
  WorkingArdue45formatting wbWorkingARDue45
End Sub

Function OpenWkbWorkingARDue45() As Workbook
  Dim sPath As String, sName As String
  sName = "WorkingARdue45.xlsx"
  sPath = Environ("USERPROFILE") & "\Desktop\" & sName
  Set OpenWkbWorkingARDue45 = Workbooks.Open(Filename:=sPath)
End Function
Function OpenWkbARDue45() As Workbook
  Dim sPath As String, sName As String
  sName = "ARdue45.xlsx"
  sPath = Environ("USERPROFILE") & "\Desktop\" & sName
  Set OpenWkbARDue45 = Workbooks.Open(Filename:=sPath)
End Function

Sub Ardue45formatting(wkb As Workbook)
  Dim r As Variant
  With wkb.Worksheets(1)
    .Range("A2:A500").ClearContents
    .Columns("I:I").ColumnWidth = 16.14
    .Columns("C:C").ColumnWidth = 18.29
    .Columns("B:B").ColumnWidth = 15.86
    .Columns("A:I").AutoFilter
    For r = 2 To LastRow(wkb.Worksheets(1)) ' In .Range("A1:" & .Range("A1").End(xlDown).Address)
      If .Cells(r, 7).Value > 0 Then
        .Rows(r).EntireRow.Font.Bold = True
      End If
    Next
  End With
End Sub
Sub WorkingArdue45formatting(wkb As Workbook)
  Dim r As Variant
  With wkb.Worksheets(1)
    .Range("A2:A500").ClearContents
    .Columns("I:I").ColumnWidth = 16.14
    .Columns("C:C").ColumnWidth = 18.29
    .Columns("B:B").ColumnWidth = 15.86
    .Columns("A:I").AutoFilter
    For r = 2 To LastRow(wkb.Worksheets(1)) ' In .Range("A1:" & .Range("A1").End(xlDown).Address)
      If .Cells(r, 7).Value > 0 Then
        .Rows(r).EntireRow.Font.Bold = True
      End If
    Next
  End With
End Sub

Sub CopyData(wkbFrom As Workbook, wkbTo As Workbook)
  Dim wsFrom As Worksheet, wsTo As Worksheet
  Dim lr As Variant, lrTarget As Variant
  Set wsFrom = wkbFrom.Worksheets(1)
  Set wsTo = wkbTo.Worksheets(1)
  lr = LastRow(wsFrom)
  If lr > 0 Then
    lrTarget = LastRow(wsTo)
    If lrTarget > 0 Then
      wsFrom.Range("A2:I" & lr).Copy wsTo.Cells(lrTarget + 2, 1)
    End If
  End If
End Sub

Sub MergeData(wkbFrom As Workbook, wkbTo As Workbook)
  Dim wsFrom As Worksheet, wsTo As Worksheet, CrntIDs As Scripting.Dictionary
  Dim lFromRow As Variant, lToRow As Variant, r As Long, i As Long
  Set wsFrom = wkbFrom.Worksheets(1)
  Set wsTo = wkbTo.Worksheets(1)
  lToRow = LastRow(wsTo)
  If lToRow > 0 Then
    ' collect Customer Numbers in To file for matching to incoming records
    Set CrntIDs = New Dictionary
    For r = 2 To lToRow
      CrntIDs.Add CStr(wsTo.Cells(r, 3).Value), r
    Next r
  End If
  lFromRow = LastRow(wsFrom)
  If lFromRow > 0 Then
    For r = 2 To lFromRow
      If CrntIDs.Exists(CStr(wsFrom.Cells(r, 3).Value)) Then
        ' matched customer ids so copy part of record
        i = CrntIDs(CStr(wsFrom.Cells(r, 3).Value))
        wsFrom.Range("A" & r & ":D" & r).Copy wsTo.Cells(i, 1)
        wsFrom.Range("F" & r & ":I" & r).Copy wsTo.Cells(i, 6)
      Else
        ' no match of customer id so copy entire record and increment record count
        wsFrom.Range("A" & r & ":I" & r).Copy wsTo.Cells(lToRow + 1, 1)
        lToRow = lToRow + 1
      End If
    Next r
  End If
End Sub

Function LastRow(sh As Worksheet) As Variant
  On Error Resume Next
  LastRow = sh.Cells.Find(What:="*", _
                          After:=sh.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
  On Error GoTo 0
End Function
Function LastColumn(sh As Worksheet) As Variant
  On Error Resume Next
  LastColumn = sh.Cells.Find(What:="*", _
                             After:=sh.Range("A1"), _
                             Lookat:=xlPart, _
                             LookIn:=xlFormulas, _
                             SearchOrder:=xlByColumns, _
                             SearchDirection:=xlPrevious, _
                             MatchCase:=False).Column
  On Error GoTo 0
End Function

Lots to talk about here but check it out and then ask me some questions so I can help you understand what I did and why.
VBA Code:
Option Explicit

Sub MasterARdue45()
  Dim wbARDue45 As Workbook, wbWorkingARDue45 As Workbook
  Set wbARDue45 = OpenWkbARDue45
  Set wbWorkingARDue45 = OpenWkbWorkingARDue45
  Ardue45formatting wbARDue45
  'CopyData wbARDue45, wbWorkingARDue45
  MergeData wbARDue45, wbWorkingARDue45
  WorkingArdue45formatting wbWorkingARDue45
End Sub

Function OpenWkbWorkingARDue45() As Workbook
  Dim sPath As String, sName As String
  sName = "WorkingARdue45.xlsx"
  sPath = Environ("USERPROFILE") & "\Desktop\" & sName
  Set OpenWkbWorkingARDue45 = Workbooks.Open(Filename:=sPath)
End Function
Function OpenWkbARDue45() As Workbook
  Dim sPath As String, sName As String
  sName = "ARdue45.xlsx"
  sPath = Environ("USERPROFILE") & "\Desktop\" & sName
  Set OpenWkbARDue45 = Workbooks.Open(Filename:=sPath)
End Function

Sub Ardue45formatting(wkb As Workbook)
  Dim r As Variant
  With wkb.Worksheets(1)
    .Range("A2:A500").ClearContents
    .Columns("I:I").ColumnWidth = 16.14
    .Columns("C:C").ColumnWidth = 18.29
    .Columns("B:B").ColumnWidth = 15.86
    .Columns("A:I").AutoFilter
    For r = 2 To LastRow(wkb.Worksheets(1)) ' In .Range("A1:" & .Range("A1").End(xlDown).Address)
      If .Cells(r, 7).Value > 0 Then
        .Rows(r).EntireRow.Font.Bold = True
      End If
    Next
  End With
End Sub
Sub WorkingArdue45formatting(wkb As Workbook)
  Dim r As Variant
  With wkb.Worksheets(1)
    .Range("A2:A500").ClearContents
    .Columns("I:I").ColumnWidth = 16.14
    .Columns("C:C").ColumnWidth = 18.29
    .Columns("B:B").ColumnWidth = 15.86
    .Columns("D:D").AutoFit
    .Columns("E:E").ColumnWidth = 37.25
    .Columns("F:H").AutoFit
      
    For r = 2 To LastRow(wkb.Worksheets(1)) ' In .Range("A1:" & .Range("A1").End(xlDown).Address)
      If .Cells(r, 7).Value > 0 Then
        .Rows(r).EntireRow.Font.Bold = True
      End If
    Next
  End With
End Sub

Sub CopyData(wkbFrom As Workbook, wkbTo As Workbook)
  Dim wsFrom As Worksheet, wsTo As Worksheet
  Dim lr As Variant, lrTarget As Variant
  Set wsFrom = wkbFrom.Worksheets(1)
  Set wsTo = wkbTo.Worksheets(1)
  lr = LastRow(wsFrom)
  If lr > 0 Then
    lrTarget = LastRow(wsTo)
    If lrTarget > 0 Then
      wsFrom.Range("A2:I" & lr).Copy wsTo.Cells(lrTarget + 2, 1)
    End If
  End If
End Sub

Sub MergeData(wkbFrom As Workbook, wkbTo As Workbook)
  Dim wsFrom As Worksheet, wsTo As Worksheet, CrntIDs As Scripting.Dictionary
  Dim lFromRow As Variant, lToRow As Variant, r As Long, i As Long
  Set wsFrom = wkbFrom.Worksheets(1)
  Set wsTo = wkbTo.Worksheets(1)
  lToRow = LastRow(wsTo)
  If lToRow > 0 Then
    ' collect Customer Numbers in To file for matching to incoming records
    Set CrntIDs = New Dictionary
    For r = 2 To lToRow
      CrntIDs.Add CStr(wsTo.Cells(r, 3).Value), r
    Next r
  End If
  lFromRow = LastRow(wsFrom)
  If lFromRow > 0 Then
    For r = 2 To lFromRow
      If CrntIDs.Exists(CStr(wsFrom.Cells(r, 3).Value)) Then
        ' matched customer ids so copy part of record
        i = CrntIDs(CStr(wsFrom.Cells(r, 3).Value))
        wsFrom.Range("A" & r & ":D" & r).Copy wsTo.Cells(i, 1)
        wsFrom.Range("F" & r & ":I" & r).Copy wsTo.Cells(i, 6)
      Else
        ' no match of customer id so copy entire record and increment record count
        wsFrom.Range("A" & r & ":I" & r).Copy wsTo.Cells(lToRow + 1, 1)
        lToRow = lToRow + 1
      End If
    Next r
  End If
End Sub

Function LastRow(sh As Worksheet) As Variant
  On Error Resume Next
  LastRow = sh.Cells.Find(What:="*", _
                          After:=sh.Range("A1"), _
                          Lookat:=xlPart, _
                          LookIn:=xlFormulas, _
                          SearchOrder:=xlByRows, _
                          SearchDirection:=xlPrevious, _
                          MatchCase:=False).Row
  On Error GoTo 0
End Function
Function LastColumn(sh As Worksheet) As Variant
  On Error Resume Next
  LastColumn = sh.Cells.Find(What:="*", _
                             After:=sh.Range("A1"), _
                             Lookat:=xlPart, _
                             LookIn:=xlFormulas, _
                             SearchOrder:=xlByColumns, _
                             SearchDirection:=xlPrevious, _
                             MatchCase:=False).Column
  On Error GoTo 0
End Function

HI vw412
THank you again for helping me with this last week. I made a couple of tweaks to the code and I have been using it and I am looking to do one minor adjustment. I have tried and tried to get the adjustments made myself and I am stuck. In the MergeData Sub, I am trying to merge the data in column A in the wkbTo Workbook along with Column E. Ive tried to add another scripting dictionary. I am hoping you could help me one more time.
 

Attachments

  • Screenshot 2021-05-07 133020.png
    Screenshot 2021-05-07 133020.png
    16.2 KB · Views: 1

vw412

Active Member
Joined
Dec 16, 2011
Messages
343
Office Version
  1. 2019
  2. 2016
  3. 2010
  4. 2007
Platform
  1. Windows

ADVERTISEMENT

I need some more info. What do you mean "merge the data in column A in the wkbTo workbook along with Column E"? Do you mean you are trying to get Column A and Column E combined together? Or is there some other "merge" you mean. As above pictures of the before and after will help.
 

Elliottj2121

New Member
Joined
Apr 15, 2021
Messages
15
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
I need some more info. What do you mean "merge the data in column A in the wkbTo workbook along with Column E"? Do you mean you are trying to get Column A and Column E combined together? Or is there some other "merge" you mean. As above pictures of the before and after will help.
In the merge sub, CrntIDs collect the customer numbers in column C and compared it against the incoming data with the following arguments:
1. If CrntIDs existed in the both the old data and the new data, column A:D and F:I in each row of wsFrom is copied leaving the wsTo column E data.

2. If CrntIds does not exist in both wsFrom and wsTo then each column in wsFrom A:I in each row is copied to wsTo

In arguement one, I'm looking to keep wsTo column A data along with column E.

Can I change this line of code:

wsFrom.Range("A" & r & ":D" & r).Copy wsTo.Cells(i, 1)

To this:

wsFrom.Range("B" & r & ":D" & r).Copy wsTo.Cells(i, 2)
 

vw412

Active Member
Joined
Dec 16, 2011
Messages
343
Office Version
  1. 2019
  2. 2016
  3. 2010
  4. 2007
Platform
  1. Windows
That should work. Let me know.
 

Watch MrExcel Video

Forum statistics

Threads
1,132,703
Messages
5,654,823
Members
418,155
Latest member
demasisi

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
Top