VBA MACRO COPY and PASTE BASED ON CONDITION BETWEEN EXCEL WORKBOOKS

Hello - I have edited my notes and added a zipfile. Hope this will be helpfull and thank you for the attention.

Picking the two folders is easy enough...

Sub test()

'1. Ask for the prior week (PW) path to be selected
    Dim PW As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Prior Week Folder"
        If .Show = -1 Then
            PW = .SelectedItems(1)
        Else
            MsgBox "No folder selected."
            Exit Sub
        End If
    End With

'2. Ask for the current week (CW) path to be selected
    Dim CW As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Current Week Folder"
        If .Show = -1 Then
            CW = .SelectedItems(1)
        Else
            MsgBox "No folder selected."
            Exit Sub
        End If
    End With
    
'3. Create two new fields at the end of the table of (CW) named (PFName and PLName)

'4. If the record number (Encounter ID) in CW exist in PW sheet (we have a match)
'   then we copy/paste (Patient First Name and Patient Last Name) from the PW sheet
'   to the new fields (PFName and PLName) in CW sheet.

    
    MsgBox PW & vbNewLine & CW


End Sub

Now we need to know the names of the files in those folders to open, and also the names of the worksheets in each of those files to work on.

Thank you Dangelor! I have made some clarifications to the intial request and supplied a zip-file.

Thank you Ali!

I know I will forget to mention everything:
1. When we receive the file, first we go over the field named "TERMED" and sort,
2. We look where the value is "Yes", that is an indication there this is a termed person.
3. We note the corresponding Document Owner Name, lets say ODNAME-153
3. Now We delete all records for that (Document Owner Name, ODNAME-153) before we do any work. In other words; we delete all records where "Note ID" is showing more than once but first we make sure that Document Owner Name is Terrmed in one or more records. Hope this makes sense. If you think it is better to include the mechanism in the code to delete these or leave it out as we can do that prior to running any code. Thanks!

After we remove the ALL records for any Document Owner Names that are termed, there should not be any duplicate Note ID, all Note ID's should be unique and that would be the primary key for each record.

Thank you very much Mumps1.
WHen I try this code I get the following error message
"Run-time error 9, supscription out of range" and when I click on debug it at at
" For i = LBound(v2) To UBound(v2)
dic.Add v2(i, 18), Nothing

That is the issue, I pasted your macro to a new excel workbook. I was hoping to save the macro to a button in a stand alone excel for the users to click on it so they can do the process since they users don't know how to use macro.
Also, I was going to ask if the formatting for the three fields coped and pasted would be same from PP to CP, reason for that they cells in the three fields are colored based on the review and if it was just text copy/paste it will loss the colors.

Thank you again for all your help, greatly appreciated.

Just so I understand before I answer, I am using the same files I sent you in the zip folder (PP, and CP)
Where should I paste the macro please? New workbook-sheet, PP, or the CP? and should I paste the code as new Module?

I just don't understand about the existence of PP.xlsx and CP.xlsx.

This is for PP + Comments and CP + Comments workbooks.

Sub test()
    Dim fn(1) As String, a(1), i As Long, ii As Long, x
    fn(0) = Application.GetOpenFilename("Excel Book,*xls?", , "Select PP+Comments")
    If fn(0) = "False" Then Exit Sub
    fn(1) = Application.GetOpenFilename("Excel Book,*xls?", , "Select CP+Comments")
    If fn(1) = "False" Then Exit Sub
    Application.ScreenUpdating = False
    With Workbooks.Open(fn(0)).Sheets(1).[a2].CurrentRegion
        a(0) = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), [{18,2,3,4}])
        .Parent.Parent.Close False
    End With
    With Workbooks.Open(fn(1)).Sheets(1).[a2].CurrentRegion
        a(1) = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), [{2,3,4,18}])
        For i = 2 To UBound(a(1), 1)
            x = Application.Match(a(1)(i, 4), Application.Index(a(0), 0, 1), 0)
            For ii = 1 To 3
                If IsNumeric(x) Then
                    a(1)(i, ii) = a(0)(x, ii + 1)
                Else
                    a(1)(i, ii) = Empty
                End If
            Next
        Next
        .Columns(2).Resize(UBound(a(1), 1), 3) = a(1)
        .Parent.Parent.Close True
    End With
    Application.ScreenUpdating = True
End Sub

Current period's new excel file is PP,
Prior Peiod excel file that was reviewd and comments has been added

So, we receive (CP) file, we need to compare with (PP+Comments), we copy and paste the three fields from the PP+Comments to CP where the "Note ID" is same. After we copy paste we start revieing other records in CP and we type new comments for the new records we reviewed. Once completed the review we save the file ( This excel file becomes the PP+Comments once the FUTURE new period excel file is received.) then we start again in a loop. Hope this helps.

Ok, will try it in a new book again and will let you know. Thank you!

Mumps1 -
I just tried and I got the same error as before
"Run-time error 9, supscription out of range" and when I click on debug it at at
" For i = LBound(v2) To UBound(v2)
dic.Add v2(i, 18), Nothing

I am attaching the two files I used.

Originally Posted by Mumps1

The CP file doesn't contain the Assess, Comments and ECC columns.

Hi Mumps1 -
Thank you very much for the help in this.That is correct, the CP doesn't contain the three fields, the fields will need to be created in it.

Now I think I understand.

Insert 3 columns in CP.xlsx with the results.

Sub test()
    Dim fn(1) As String, a(1), b, i As Long, ii As Long, x
    fn(0) = Application.GetOpenFilename("Excel Book,*xls?", , "Select PP+Comments")
    If fn(0) = "False" Then Exit Sub
    fn(1) = Application.GetOpenFilename("Excel Book,*xls?", , "Select CP")
    If fn(1) = "False" Then Exit Sub
    Application.ScreenUpdating = False
    With Workbooks.Open(fn(0)).Sheets(1).[a2].CurrentRegion
        a(0) = Application.Index(.Value, Evaluate("row(1:" & .Rows.Count & ")"), [{2,3,4,18}])
        .Parent.Parent.Close False
    End With
    With Workbooks.Open(fn(1)).Sheets(1).[a2].CurrentRegion
        a(1) = Application.Index(.Value, 0, 15)
        ReDim b(1 To UBound(a(1), 1), 1 To 3)
        For i = 2 To UBound(a(1), 1)
            x = Application.Match(a(1)(i, 1), Application.Index(a(0), 0, 4), 0)
            If IsNumeric(x) Then
                For ii = 1 To 3
                    b(i, ii) = a(0)(x, ii)
                Next
            End If
        Next
        .Columns("b:d").Insert
        .Columns("b:d").Value = b
        .Range("b1:d1") = a(0)
        .Parent.Parent.Close True
    End With
    Application.ScreenUpdating = True
End Sub

Jindon -
Thank you first of all. Is it possible to preserve the format of the cells for the three fileds (font color, cell color...) excaxtly copy and paste with all the formatting?

Change to

Sub test()
    Dim fn(1) As String, a, i As Long, r As Range, x
    fn(0) = Application.GetOpenFilename("Excel Book,*xls?", , "Select PP+Comments")
    If fn(0) = "False" Then Exit Sub
    fn(1) = Application.GetOpenFilename("Excel Book,*xls?", , "Select CP")
    If fn(1) = "False" Then Exit Sub
    Application.ScreenUpdating = False
    With Workbooks.Open(fn(0)).Sheets(1).[a2].CurrentRegion
        Set r = Union(.Columns("b:d"), .Columns("r"))
        With Workbooks.Open(fn(1)).Sheets(1).[a2].CurrentRegion
            a = Application.Index(.Value, 0, 15)
            .Columns("b:d").Insert
            r.Rows(1).Copy .Cells(1, "b").Resize(, 3)
            For i = 2 To UBound(a, 1)
                x = Application.Match(a(i, 1), r.Areas(2), 0)
                If IsNumeric(x) Then r.Rows(x).Resize(, 3).Copy .Cells(i, "b")
            Next
            Application.CutCopyMode = False
            .Parent.Parent.Close True
        End With
        .Parent.Parent.Close False
    End With
    Application.ScreenUpdating = True
End Sub

So Filtering

Appointment status = Arrived
And
Occupation = Nurse practitioner or Physician or Physician assistant
And
Note Type = Office or Nurse or Letter or Teleph or Pediat or RES*
And
Note STatus = Needs input or Amended Signed or Amended Unsigned

Is that correct?

If that's true, CP.xlsx uploaded has no matched data, correct?

See attached
Sheet1 must have filtering list for Advanced Filter.

Sub test()
    Dim fn(1) As String, a, i As Long, r As Range, x
    fn(0) = Application.GetOpenFilename("Excel Book,*xls?", , "Select PP+Comments")
    If fn(0) = "False" Then Exit Sub
    fn(1) = Application.GetOpenFilename("Excel Book,*xls?", , "Select CP")
    If fn(1) = "False" Then Exit Sub
    Application.ScreenUpdating = False
    With Workbooks.Open(fn(0)).Sheets(1).[a2].CurrentRegion
        Set r = Union(.Columns("b:d"), .Columns("r"))
        With Workbooks.Open(fn(1)).Sheets(1).[a2].CurrentRegion
            FilterAndDelete .Cells
            a = Application.Index(.Value, 0, 15)
            .Columns("b:d").Insert
            r.Rows(1).Copy .Cells(1, "b").Resize(, 3)
            For i = 2 To UBound(a, 1)
                x = Application.Match(a(i, 1), r.Areas(2), 0)
                If IsNumeric(x) Then r.Rows(x).Resize(, 3).Copy .Cells(i, "b")
            Next
            Application.CutCopyMode = False
            .Parent.Parent.Close True
        End With
        .Parent.Parent.Close False
    End With
    Application.ScreenUpdating = True
End Sub

Sub FilterAndDelete(rng As Range)
    Dim r As Range, x
    With rng
        Set r = .Offset(, .Columns.Count + 2).Cells(1)
        ThisWorkbook.Sheets(1).Cells(1).CurrentRegion.Copy r
        .AdvancedFilter 1, r.CurrentRegion
        If .Columns(1).SpecialCells(12).Count > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        If .Parent.FilterMode Then .Parent.ShowAllData
        r.CurrentRegion.Clear
        x = Filter(.Parent.Evaluate("transpose(if(" & .Columns("d").Address & _
            "=""yes""," & .Columns("b").Address & "))"), False, 0)
        .AutoFilter 2, x, 7
        If .Columns(1).SpecialCells(12).Count > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        If .Parent.FilterMode Then .Parent.ShowAllData
    End With
End Sub

OK, tables...

Sub test()
    Dim fn(1) As String, a, i As Long, r As Range, x, tbl As ListObject
    fn(0) = Application.GetOpenFilename("Excel Book,*xls?", , "Select PP+Comments")
    If fn(0) = "False" Then Exit Sub
    fn(1) = Application.GetOpenFilename("Excel Book,*xls?", , "Select CP")
    If fn(1) = "False" Then Exit Sub
    Application.ScreenUpdating = False
    With Workbooks.Open(fn(0)).Sheets(1).ListObjects(1)
        Set r = Union(.ListColumns(2).Range.Resize(, 3), .ListColumns(18).Range)
        With Workbooks.Open(fn(1)).Sheets(1)
            Set tbl = .ListObjects(1)
            FilterAndDelete tbl
            With tbl
                a = Application.Index(.Range, 0, 15)
                .Parent.Columns("b:d").Insert
                r.Rows(1).Copy .HeaderRowRange.Columns(2)
                For i = 2 To UBound(a, 1)
                    x = Application.Match(a(i, 1), r.Areas(2), 0)
                    If IsNumeric(x) Then r.Rows(x).Resize(, 3).Copy .ListColumns(2).Range(i)
                Next
            End With
            Application.CutCopyMode = False
            .Parent.Close True
        End With
        .Parent.Parent.Close False
    End With
    Application.ScreenUpdating = True
End Sub

Sub FilterAndDelete(rng As ListObject)
    Dim r As Range, x
    With rng
        Set r = .Parent.Cells(1, .ListColumns.Count + .ListColumns(1).Range.Column + 2)
        ThisWorkbook.Sheets(1).Cells(1).CurrentRegion.Copy r
        .Range.AdvancedFilter 1, r.CurrentRegion
        If .ListColumns(1).Range.SpecialCells(12).Count > 1 Then
            .Offset(1).Resize(.Rows.Count - 1).EntireRow.Delete
        End If
        If .Parent.FilterMode Then .Parent.ShowAllData
        r.CurrentRegion.Clear
        x = Filter(.Parent.Evaluate("transpose(if(" & .ListColumns(4).Range.Address & _
            "=""yes""," & .ListColumns(2).Range.Address & "))"), False, 0)
        .Range.AutoFilter 2, x, 7
        If .ListColumns(1).Range.SpecialCells(12).Count > 1 Then
            .DataBodyRange.EntireRow.Delete
        End If
        If .Parent.FilterMode Then .ShowAutoFilter = False
    End With
End Sub

Thank you AliGW for the infromation. Will do!

I wrote as you requested.

Upload your EXACT deired result of new CP workbook from above 2 workbooks.

I am very sorry. I don't know why. See attached resulted file.

If the last workbook is your desired result, my code is working.
what's wrong?

My apology, maybe my explination is not clear:
The file I send you last (CP_2022Oct06 083938) is not the desired result but it is the result from using the last code based on the two files (CP) and (PP+Comments) Attached to this reply is the desired result.

I tried to explaining in my prior reply using the colored records in (CP) and what sould happen to these records;
(RED and BLUE colored records in the CP would not be included in the desired new result for the reasons explianed in the prior reply) and
(GREEN would have matched "NOTE ID" in (PP+Comments) with comments in the 3-fields, thus we need to copy/past comments from the three fields from (PP+Comments) to the new desired new result. in conclusion, the new desired file would have all the (CP) records except the records in BLUE and RED and would have the comments copied for the matched "NOTE ID" records.

I hope this helps.

In you result, you have many rows with Physician in Occupation column.

Also Arrived in Appointment Status column.

why?

How are you actualy picking the rows to be deleted from CP.xls manually?

Maybe I wanst clear on the filtering. We do the following filtering to keep those meeting the condition and not to excleude.

FILTERING:
1. First we filter records to keep (include) when "Appointment status" = Arrived
2. Next, from the remaining result we filter records to keep (include) when "Occupation" = Nurse practitioner, or Physician or Physician assistant
3. Next, from the remaining result we filter records to keep (include) "Note Type" = Office, or Nurse, or Letter, or Teleph, pr Pediat, or any that STARTS with "RES"
4. Next, from the remaining result we filter records to keep (include) "Note STatus" = Needs input, Amended Signed, Amended Unsigned

Do I have any conflict in the test data? (recall that I tried to make up the test files for the CP and PP+Comments files and hope there are no conflict.)

Dear Jindon -

I am very sorry to keep bothering you with this request, you have been very patient and helpfull.
I have made a new TEST files for "CP" and "PP+Comments" as I found some inconsistancy with my prior files.
With the consideration about the filtering process I mentioned in the preior reply I am attaching the new files along with the Desired file.

I also attached CP-Explianed I tried to highlight with colors to make it easy to understand.
GREEN, are exsisting in PP+Commnets with notes in any of the 3 fields, Thus notes from the 3 fields will be copied
RED- Document Owner Name is TEREMED
BLUE - Records that should not show in the result, Highlighted reason in Dark Blue.

Also, I am receiving a message write after the Save As file "CP_Oct..."The message says "Delete entire sheet now?"

Explanation of #49 and files in #50 helped.

try the attached.

Sub test()
    Dim fn(2) As String, a, i As Long, r As Range, x, tbl As ListObject, dic As Object
    fn(0) = Application.GetOpenFilename("Excel Book,*xls?", , "Select PP+Comments")
    If fn(0) = "False" Then Exit Sub
    fn(1) = Application.GetOpenFilename("Excel Book,*xls?", , "Select CP")
    If fn(1) = "False" Then Exit Sub
    fn(2) = Application.GetSaveAsFilename("CP_" & Format$(Now, "yyyymmmdd hhmmss"), _
                                    "Excel Book,*.xlsx", , "Enter New File Name")
    If fn(2) = "False" Then Exit Sub
    Application.ScreenUpdating = False
    With ThisWorkbook.Sheets(1).Cells(1).CurrentRegion
        ReDim myList(1 To 2, 1 To .Columns.Count)
        For i = 1 To .Columns.Count
            myList(1, i) = .Cells(1, i)
            myList(2, i) = Filter(.Parent.Evaluate("transpose(if(" & .Columns(i).Offset(1).Address & _
                        "<>""""," & .Columns(i).Offset(1).Address & "))"), False, 0)
        Next
    End With
    With Workbooks.Open(fn(0)).Sheets(1).ListObjects(1)
        Set r = Union(.ListColumns(2).Range.Resize(, 3), .ListColumns(18).Range)
        With Workbooks.Open(fn(1)).Sheets(1)
            Set tbl = .ListObjects(1)
            For i = 1 To UBound(myList, 2)
                myList(2, i) = GetAll(myList(2, i), tbl, myList(1, i))
            Next
            FilterAndDelete tbl, myList, fn(2)
            .Parent.Close False
        End With
        fn(2) = Mid$(fn(2), InStrRev(fn(2), "\") + 1)
        With Workbooks(fn(2)).Sheets(1)
            Set tbl = .ListObjects(1)
            With tbl
                a = Application.Index(.Range, 0, 15)
                .Parent.Columns("b:d").Insert
                r.Rows(1).Copy .HeaderRowRange.Columns(2)
                For i = 2 To UBound(a, 1)
                    x = Application.Match(a(i, 1), r.Areas(2), 0)
                    If IsNumeric(x) Then r.Rows(x).Resize(, 3).Copy .ListColumns(2).Range(i)
                Next
            End With
            Application.CutCopyMode = False
            .Parent.Close True
        End With
        .Parent.Parent.Close False
    End With
    Application.ScreenUpdating = True
End Sub

Sub FilterAndDelete(rng As ListObject, myList, fn As String)
    Dim a, x, i As Long, ii As Long, iii As Long, ub As Long, temp
    With rng
        temp = .Name
        If .ShowAutoFilter Then .ShowAutoFilter = False
        rng.ShowAutoFilter = True
        For i = 1 To UBound(myList, 2)
            .Range.AutoFilter myList(1, i), myList(2, i), 7
        Next
        .Parent.Copy
        With ActiveWorkbook.Sheets(1)
            .ListObjects(1).Delete
            .Parent.SaveAs fn
            rng.Range.SpecialCells(12).Copy .[a2]
            .ListObjects.Add(1, .[a2].CurrentRegion, 1).Name = temp
            .ListObjects(1).TableStyle = ""
            Set rng = .ListObjects(1)
        End With
    End With
    With rng
        x = Filter(.Parent.Evaluate("transpose(if(" & .ListColumns(4).Range.Address & _
            "=""yes""," & .ListColumns(2).Range.Address & "))"), False, 0)
        If UBound(x) > -1 Then
            .ShowAutoFilter = True
            .Range.AutoFilter 2, x, 7
            If .ListColumns(1).Range.SpecialCells(12).Count > 1 Then
                .DataBodyRange.EntireRow.Delete
            End If
        End If
        .ShowAutoFilter = False
    End With
End Sub

Function GetAll(x, tbl As ListObject, ref)
    Dim a, ub As Long, i As Long, ii As Long, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(x) To UBound(x)
        If x(i) Like "*[*]*" Then
            a = tbl.ListColumns(ref).Range.Value
            For ii = 1 To UBound(a, 1)
                If a(ii, 1) Like x(i) Then dic(a(ii, 1)) = Empty
            Next
            If dic.Count Then
                ub = UBound(x)
                ReDim Preserve x(ub + dic.Count)
                For ii = 0 To dic.Count - 1
                    x(ub + ii + 1) = dic.keys()(ii)
                Next
            End If
        End If
    Next
    GetAll = x
End Function

Dear Jindon - This last code seems to be working with the test files. I will be in the office tomorrow to test with the actual real files. I will keep you updated.
I can't thank you enough for the effort and patients.

Extract new “UNF” file from the system

How?

save with today’s date and time in a new folder Let’s say it is saved as “UNF-11282022”

New folder in which folder?

Hi Jindon -

We have a internal software system where we run the report, once the report is ready we save it as (UNF-Todays date) into a specific folder on our shared drive called UNF-Master (E://UNF-MASTER) DId I answer your question?