• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

search multiple criteria from one file, find/match in another file

R

r121a947

Member
I have a music catalog (> 42K unique records). A unique record is defined by columns B thru E. From these records I have created scores of playlists, which are stored in individual workbooks. (I am in the process of transferring the playlist files to a single workbook, each playlist as a named worksheet.)

Many of the songs have been used in multiple playlists, and I am trying to create a routine to update the catalog file to show in which playlists a particular song has been used. The total number of playlist songs is > 10K, so it has to be automated.

I am very new to Excel and VBA, so what I have pieced together is mostly “monkey see, monkey do” for each step. I am certain there are far better and easier ways to do these things . . . I just don't know how.

The enclosed version almost works; I don't get consistent results when running the routine with the same two files, multiple times.

What can cause such inconsistency? Is my Excel install buggy? Should I reinstall Excel?

Any and all help will be greatly appreciated. I have attached sample files. Thank you for your interest and assistance.

p.s. If anyone wants to see the playlists, they are on Spotify under my user ID: r121a947.
 

Attachments

  • tempcatx.xlsm
    91.8 KB · Views: 7
  • air8.xlsm
    97.3 KB · Views: 7
I have a version that works, except when the first match criterion is not unique. Even though the second thru fourth criteria are different than when the first criterion was first called, the routine does not properly process the second instance of the nonunique criterion.

I have tried redefining the criterion value before beginning a succeeding loop, but that had no effect.

Thanks, in advance, for your interest and assistance.
 

Attachments

  • air8.xlsm
    98.1 KB · Views: 4
  • tempcatx.xlsm
    91.8 KB · Views: 5
I misunderstood, believing a cross post involved multiple forums at a single site, not different sites.

I understand, now.

Please excuse my mistake.
 
Your data is in an almost perfect format for advanced filtering. It's missing headers.
Put the following macro in your tempcatx.xlsm file in a fresh standard code-module.
Make sure your other sample file is also already open (air8.xlsm).
The code below has lines in it which aren't necessary for its operation but are there to show you what's happening. These lines have a 'debug line comment after them; these lines can be deleted/commented out.
Run the macro one line at a time using the F8 keyboard key so you can follow what's going on. If you like it the macro can be considerably shortened. Currently there's no code to handle when absolutely no matches are found…
Code: 
Sub blah()
With ThisWorkbook.Sheets("Sheet1")    'the database
  'Put some headers in:
  .Rows(1).Insert
  .Range("B1:E1").Value = Array("B", "C", "D", "E")
  'Determine the range that needs to be filtered:
  Set RngToFilter = Intersect(.Columns("B:E"), .UsedRange)
  Application.Goto RngToFilter    'debug line

  'If you're going to loop through several workbooks, this is where the loop starts.
  Set SceWb = Workbooks("air8.xlsm")    'this is just one file, hard coded; you'll be opening them your way, probably in a loop.
  Set SceSht = SceWb.Sheets("Sheet1")    'are all your playlist sheets called "Sheet1"?
  'Put some headers in:
  SceSht.Rows(1).Insert
  SceSht.Range("B1:E1").Value = Array("B", "C", "D", "E")
  'Set the criteria range for advancd filter:
  Set RngCrit = Range(SceSht.Range("B1"), SceSht.Range("B1").End(xlDown)).Resize(, 4)
  Application.Goto RngCrit    'debug line
  RngToFilter.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=RngCrit, Unique:=False
  'Column L visible cells are the cell we need to update:
  Set CellsToUpdate = Intersect(.Columns("L"), RngToFilter.EntireRow, RngToFilter.EntireRow.Offset(1)).SpecialCells(xlCellTypeVisible)
  Application.Goto CellsToUpdate    'debug line
  For Each cll In CellsToUpdate.Cells
    Application.Goto cll    'debug line
    If cll.Value = "" Then cll.Value = SceWb.Name Else cll.Value = cll.Value & ", " & SceWb.Name
  Next cll
  SceSht.Rows(1).Delete    'removes the headers row from the playlist sheet. You won't need this if you're going to close that playlist workook without saving it.
  'you might get away with putting the next three lines ouside the loop:
  On Error Resume Next
  .ShowAllData
  On Error GoTo 0
  'If you're going to loop through several workbooks, this is where the loop ends.

  .Rows(1).Delete    'remove the headers from the catalogue/database sheet
End With    'ThisWorkbook.Sheets("Sheet1")
End Sub
There must be no blank cells in column B of your playlists; the tracks matched will only go as far as the first blank cell in that column. If this is a problem we could do it another, more convoluted, way.
 
Last edited:
Thank you very much for your assistance.

I am trying to visualize everything as I read thru . . . I am very new to Excel and VBA, so I might not grasp everything right away.

Does the matching from the playlist file to the catalog file take place via

RngToFilter.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=RngCrit, Unique:=False ?

Everything else seems straight forward.

Re your concerns/questions:

Currently, each playlist is in a separate workbook, and the files can be renamed to be the update code. Alternatively, each playlist could be a separate named worksheet in one workbook. Which do you think will be easier to automate?

There are no blank spaces in the B column (song title) of any playlist, although there are sometimes blanks in the C column (artist first name).

The values in each column are not unique, but across the four columns are unique, defining a unique record. Duplicate values in the B column are causing problems in the version I was working on.

I will try your version first thing tomorrow . . . I have been at this for ten hours, so far, today.

Again, thank you very much for your interest and your assistance.

p.s. If you are interested, the playlists are on Spotify, as Public Playlists under my user ID: r121a947
 
I was going to quit for the day, but your solution had me curious . . .

On the first step-thru I got an error at

Set RngCrit = Range(SceSht.Range("B1"), SceSht.Range("B1").End(xlDown)).Resize(, 4) ' error 1004, application-defined or object-defined error

I have no clue about what to do.

Thank you for your interest and your assistance.
 
Confirm you are doing this on your two attached files and that the code is in a standard code-module in the tempcatx.xlsm file, not in the ThisWorkbook code-module and not in a sheet's code-module. I'm not near a computer at the moment so I can't test nor try to reproduce the error.
 
Last edited:
Thank you.

I moved the code to Module1 and stepped thru . . . It works perfectly!!

Thank you for saving me a tremendous amount of work and aggravation.
 
p45cal said:
Confirm you are doing this on your two attached files and that the code is in a standard code-module in the tempcatx.xlsm file, not in the ThisWorkbook code-module and not in a sheet's code-module. I'm not near a computer at the moment so I can't test nor try to reproduce the error.
Click to expand...
Thank you for your interest and your assistance.

May I impose on your kindness with further questions?

Is there a way to do any of the following:

Match columns B, C, and D between the catalog and the playlist, and return/capture the value of E for those matches to use to update M in the catalog?

Filter to find records that match B, C, and D, but do not match E, between the catalog and the playlist, and update M in the catalog to show those records?

I very much appreciate your help, and I admire your knowledge. Thank you.
 
Could you supply files where this might happen (and ones in which every combination of possibilities happens) because with your current data this doesn't happen at all.
What are you hoping column M will tell you?
 
r121a947 said:
Thank you.

I moved the code to Module1 and stepped thru . . . It works perfectly!!

Thank you for saving me a tremendous amount of work and aggravation.
Click to expand...

You can help to readers of those 2 forum for learning, where you ask this questions by just put this thread's link (Address) to there.
If you don't mine please read ...this..https://chandoo.org/forum/threads/extract-unique-data-based-on-criteria.42069/

Regards,

Chirag Raval
 
p45cal said:
Could you supply files where this might happen (and ones in which every combination of possibilities happens) because with your current data this doesn't happen at all.
What are you hoping column M will tell you?
Click to expand...
Some of the playlist files are very old. I made the mistake of editing the catalog in column E, to save space, which makes some of the songs not match when running the routine.

The info in column M will tell me, beforehand, which playlist entries need to be edited to match the catalog. Then, your routine will make a perfect one-to-one match, every time.

Sample files are attached. Thank you for your interest and your assistance.
 

Attachments

  • tempcat.xlsm
    336.5 KB · Views: 6
  • dance.xlsm
    24.9 KB · Views: 6
It probably makes more sense to bring the catalog E column into the playlist than the other way around. That way, i could update the playlist to match the catalog very easily.

Thank you for your interest and your assistance.
 
Using your previous solution, and exploring the active filter function, I was able to piece together a macro that does the job. The code is pasted.

I would greatly appreciate your comments/suggestions, especially with how to capture return the playlist sheet name and active range.

Thank you for your interest and your assistance.

Code: 
Sub ComparePlaylistCatalog()
'
' ComparePlaylistCatalog Macro
' Compare playlist against catalog
'
' Keyboard Shortcut: Ctrl+Shift+Z
'
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Application.CutCopyMode = False
    Workbooks("catalog.xlsm").Sheets("Sheet1").Range("A1:L42820").AdvancedFilter _
        Action:=xlFilterCopy, CriteriaRange:=Range("B1:D72"), CopyToRange:=Range( _
        "M1"), Unique:=False
    Windows("catalog.xlsm").Activate
    Windows("playlists.xlsm").Activate
End Sub
 
I will try to find time to look at this tomorrow - been busy, and I discovered possible flaws with my first suggestion (how it deals with blank cells (which actually aren't really blank in your files) and it not discerning between say Abba and Abba2 if filtering for Abba).
 
You need to put the following macro into a standard code-module in the workbook holding the main catalogue/database. Nowhere else.
It works on the two files you attached in your msg#17, noting that the main catalogue already had headers. Also note that it might be better to unhide all rows in the tempcat file before running the macro.
It adds data to column L of the playlist; if there is more than one possibility, subsequent album names/links are added to the same row but in columns M, N O etc.
For this macro, the playlist sheets do not need headers, it's better that the main catalogue does have headers (but they're already there anyway).
There are comments in the code as before.
This still uses Advanced Filter but in quite a different way.
Note that the macro has no code to save the playlist(s) after it's finished running.
You shouldn't remove or insert rows or sort the main catalogue until you've finished using the results of this macro because the macro adds the album name to column L of the playlist using a link to the cell in the main catalogue; there's also a full blown hyperlink added to the same cell so that clicking on it will take you to the specific cell in the main catalogue. The links would probably no longer point to the right cell if you did.
Code: 
Sub UpdatePlayListFiles()
Dim AlbumCells As Range
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("Sheet1")    'the database
  'Determine the range that needs to be filtered:
  Set RngToFilter = Intersect(.Columns("B:E"), .UsedRange)
  'Application.Goto RngToFilter    'debug line
  Set CritSht = ThisWorkbook.Sheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))    'add a temporary new sheet to hold the criteria range for advanced filter.
  CritSht.Range("B2:D2").FormulaR1C1 = "='" & .Name & "'!RC=R4C"
  CritSht.Range("E2").FormulaR1C1 = "='" & .Name & "'!RC<>R4C"
  'Set the criteria range for advancd filter:
  Set RngCrit = CritSht.Range("B1:E2")
  'Application.Goto RngCrit    'debug line

  'If you're going to loop through several workbooks, this is where the loop starts.
  Set SceWb = Workbooks("dance.xlsm")    'this is just one file, hard coded; you'll be opening them your way, probably in a loop.
  Set SceSht = SceWb.Sheets("Sheet1")    'are all your playlist sheets called "Sheet1"?

  For Each rw In SceSht.Range(SceSht.Range("B1"), SceSht.Range("B1").End(xlDown)).Resize(, 4).Rows
    rw.Copy CritSht.Range("B4")
    RngToFilter.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=RngCrit, Unique:=False

    Set AlbumCells = Nothing
    On Error Resume Next
    Set AlbumCells = Intersect(.Columns("E"), RngToFilter.EntireRow, RngToFilter.EntireRow.Offset(1)).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Not AlbumCells Is Nothing Then
      'Application.Goto AlbumCells    'debug line
      Set Destn = rw.Offset(, 11).Resize(1, 1)
      'Application.Goto Destn 'debug line
      For Each cll In AlbumCells.Cells
        '  Application.Goto cll    'debug line
        Destn.Formula = "=" & cll.Address(external:=True)
        Destn.Parent.Hyperlinks.Add Anchor:=Destn, Address:=ThisWorkbook.FullName, SubAddress:=cll.Address(external:=True)    ', TextToDisplay:=cll.Value
        Set Destn = Destn.Offset(, 1)    'if there's more than one possible album it will place them in columns M,N O etc. on the same row.
      Next cll
    End If
    On Error Resume Next:  .ShowAllData:  On Error GoTo 0
  Next rw
  'If you're going to loop through several workbooks, this is where the loop ends.

  Application.DisplayAlerts = False: CritSht.Delete: Application.DisplayAlerts = True    'Delete the temporary sheet
  Application.ScreenUpdating = True
End With    'ThisWorkbook.Sheets("Sheet1")
End Sub
This macro should handle blank cells properly and only looks for exact matches. (I haven't looked to rectify this in the macro in msg#9 - if it does become a problem, come back to me and I'll investigate)
 
Your original solution has stopper working. It was working fine, earlier today. I made no changes to it between then and now, but it has just stopped working.

When run, all the catalog, except the header row, is erased, and it gives an error message: no cells were found. Comments in the code. Debug points to the Set CellstoUpdate line.

Code: 
Sub NewUpdate()
With ThisWorkbook.Sheets("Sheet1")    'the database
  'Put some headers in:
  ' .Rows(1).Insert
  ' .Range("B1:E1").Value = Array("B", "C", "D", "E")
  'Determine the range that needs to be filtered:
  Set RngToFilter = Intersect(.Columns("B:E"), .UsedRange)
  ' Application.Goto RngToFilter    'debug line

  'If you're going to loop through several workbooks, this is where the loop starts.
  Set SceWb = Workbooks("playlists.xlsm")    'ALL the playlists are in this file, each a separate sheet
  Set SceSht = SceWb.Sheets("ksB")    'THIS is the name of an individual sheet
  'Put some headers in:
  ' SceSht.Rows(1).Insert
  ' SceSht.Range("B1:E1").Value = Array("B", "C", "D", "E")
  'Set the criteria range for advancd filter:
  Set RngCrit = Range(SceSht.Range("B1"), SceSht.Range("B1").End(xlDown)).Resize(, 4)
  ' Application.Goto RngCrit    'debug line
  RngToFilter.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=RngCrit, Unique:=False
  'Column L visible cells are the cell we need to update:
  Set CellsToUpdate = Intersect(.Columns("L"), RngToFilter.EntireRow, RngToFilter.EntireRow.Offset(1)).SpecialCells(xlCellTypeVisible)
  ' THERE is an error message:  no cells were found; and all of the catalog, except the header row, has been erased
  For Each cll In CellsToUpdate.Cells
  '  Application.Goto cll    'debug line
    If cll.Value = "" Then cll.Value = SceSht.Name Else cll.Value = cll.Value & " " & SceSht.Name
  Next cll
  ' SceSht.Rows(1).Delete    'removes the headers row from the playlist sheet. You won't need this if you're going to close that playlist workook without saving it.
  'you might get away with putting the next three lines ouside the loop:
  On Error Resume Next
  .ShowAllData
  On Error GoTo 0
  'If you're going to loop through several workbooks, this is where the loop ends.

  ' .Rows(1).Delete    'remove the headers from the catalogue/database sheet
End With    'ThisWorkbook.Sheets("Sheet1")
End Sub
 
First and foremost: I got this message while I was socialising and I've had a few.
r121a947 said:
Your original solution has stopper working. It was working fine, earlier today. I made no changes to it between then and now, but it has just stopped working.
Click to expand...
You have made changes to it. You've taken out:
Code: 
SceSht.Rows(1).Insert
SceSht.Range("B1:E1").Value = Array("B", "C", "D", "E")
Now I don't know whether this playlist already sheet has headers or not, nor what these headers might be, but I strongly suspect that nothing has been erased, only hidden. There is no code to delete/erase anything.
Can you confirm/deny this?
I reiterate: I've had a few.
 
I agree that things are probably hidden, rather than erased, because the line number appearing on the left is one greater than the last row. Everything between the header row and the first blank row is probably hidden. Why would it start hiding things? Will unhiding things make a difference.

Can the filtering settings from a different routine interfere with these filtering settings? Doesn't seem like that should be the case.

Each playlist sheet has a header row, from A thru L, same as the catalog. The routine was working with the same header row, previously.

I will look at everything again, tomorrow. Have a good evening. Don't sweat anything. What you've done has already turned a mountain of work into an easily overcome hill.

Thank you for your interest and your assistance.
 
You must log in or register to reply here.
Back
Top