Result from a 2 factors research

L

Loadlucas

New Member
Joined
Jun 29, 2022
Messages
10
Office Version
  1. 2019
Platform
  1. Windows
Hi,
I am looking for a solution that would allow you to search for on the column A of 240111 Search File.xlsx the partial correspondence of a column element A of a 240111 Ask File.xlsm sheet and on column B A 240111 Search file.xlsx the Partial correspondence of a column element B of a 24011 ASK File.xlsm sheet. If the two correspondences are found on the same line, it would be necessary to return the value of the column C of the same line of the sheet B in result on column C of the sheet 24011 ASK FILE.XLSM. I did a macro but I can't make him look for concordances so that they are only true if they are found on the same line.
Here is my macro :

VBA Code: 
Sub Inject2facteurs_test()
    Dim heureDebut As Double
    Dim heureFin As Double
    Dim minutes As Integer
    Dim secondes As Integer
    Dim sh As Worksheet
    Dim wbs As String
    Dim fCol1 As Range, fCol2 As Range, fCol3 As Range, fCol4 As Range
    Dim c As Range
    
    heureDebut = Timer
    
    ' Récupérer le nom du classeur à partir de la cellule G1 de la feuille active
    wbs = ActiveSheet.Range("G1").Value
    
    ' Définir l'objet Worksheet sh en se référant à la première feuille de calcul du classeur spécifié
    Set sh = Workbooks(wbs).Worksheets(1)
    
    ' Boucle à travers chaque cellule dans la colonne A de la feuille active
    With ThisWorkbook.Worksheets("Feuil1")
        For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
            ' Réinitialiser les objets Range
            Set fCol1A = Nothing
            Set fCol2B = Nothing
            
            ' Recherche de correspondance partielle dans la première colonne de la feuille sh (colonne 1)
            Set fCol1A = sh.Columns(1).Find(c.Value, , xlValues, xlPart, , , False)
            
            ' Vérifier si la correspondance dans la colonne A de la feuille active a été trouvée
            If Not fCol1A Is Nothing Then
                ' Recherche de correspondance partielle dans la deuxième colonne de la feuille sh (colonne 2)
                Set fCol2B = sh.Columns(2).Find(c.Offset(, 1).Value, , xlValues, xlPart, , , False)
                
                ' Vérifier si la correspondance dans la colonne B de la feuille active a été trouvée
                If Not fCol2B Is Nothing And Not fCol1A Is Nothing Then
                    ' Copier la valeur de la colonne 3 de la feuille sh dans la colonne 3 de la feuille active
                    c.Offset(, 2).Value = sh.Cells(fCol1A.Row, 3).Value
                End If
            End If
        Next c
    End With
    
    heureFin = Timer
    dureeEnSecondes = heureFin - heureDebut
    
    ' Convertir en minutes et secondes
    minutes = Int(dureeEnSecondes / 60)
    secondes = dureeEnSecondes - (minutes * 60)
    
    MsgBox "La macro a pris " & minutes & " minutes et " & secondes & " secondes.", vbInformation
End Sub

Here is the Excel file with the value to search (240111 ASK FILE.xlsm) :

Capture d'écran 2024-01-11 173620.png


Here is the 240111 SEARCH FILE.xlsx file with the value to found to send the column 3 result (UNIQUEID) in the column 3 of the Excel 240111 ASK FILE.xlsm file

Capture d'écran 2024-01-11 174129.png

Hope you can help with that ...

Thank you for your help !

Loadlucas
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
Loadlucas said:
Hi,
I am looking for a solution that would allow you to search for on the column A of 240111 Search File.xlsx the partial correspondence of a column element A of a 240111 Ask File.xlsm sheet and on column B A 240111 Search file.xlsx the Partial correspondence of a column element B of a 24011 ASK File.xlsm sheet. If the two correspondences are found on the same line, it would be necessary to return the value of the column C of the same line of the sheet B in result on column C of the sheet 24011 ASK FILE.XLSM. I did a macro but I can't make him look for concordances so that they are only true if they are found on the same line.
Here is my macro :

VBA Code: 
Sub Inject2facteurs_test()
    Dim heureDebut As Double
    Dim heureFin As Double
    Dim minutes As Integer
    Dim secondes As Integer
    Dim sh As Worksheet
    Dim wbs As String
    Dim fCol1 As Range, fCol2 As Range, fCol3 As Range, fCol4 As Range
    Dim c As Range
  
    heureDebut = Timer
  
    ' Récupérer le nom du classeur à partir de la cellule G1 de la feuille active
    wbs = ActiveSheet.Range("G1").Value
  
    ' Définir l'objet Worksheet sh en se référant à la première feuille de calcul du classeur spécifié
    Set sh = Workbooks(wbs).Worksheets(1)
  
    ' Boucle à travers chaque cellule dans la colonne A de la feuille active
    With ThisWorkbook.Worksheets("Feuil1")
        For Each c In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
            ' Réinitialiser les objets Range
            Set fCol1A = Nothing
            Set fCol2B = Nothing
          
            ' Recherche de correspondance partielle dans la première colonne de la feuille sh (colonne 1)
            Set fCol1A = sh.Columns(1).Find(c.Value, , xlValues, xlPart, , , False)
          
            ' Vérifier si la correspondance dans la colonne A de la feuille active a été trouvée
            If Not fCol1A Is Nothing Then
                ' Recherche de correspondance partielle dans la deuxième colonne de la feuille sh (colonne 2)
                Set fCol2B = sh.Columns(2).Find(c.Offset(, 1).Value, , xlValues, xlPart, , , False)
              
                ' Vérifier si la correspondance dans la colonne B de la feuille active a été trouvée
                If Not fCol2B Is Nothing And Not fCol1A Is Nothing Then
                    ' Copier la valeur de la colonne 3 de la feuille sh dans la colonne 3 de la feuille active
                    c.Offset(, 2).Value = sh.Cells(fCol1A.Row, 3).Value
                End If
            End If
        Next c
    End With
  
    heureFin = Timer
    dureeEnSecondes = heureFin - heureDebut
  
    ' Convertir en minutes et secondes
    minutes = Int(dureeEnSecondes / 60)
    secondes = dureeEnSecondes - (minutes * 60)
  
    MsgBox "La macro a pris " & minutes & " minutes et " & secondes & " secondes.", vbInformation
End Sub

Here is the Excel file with the value to search (240111 ASK FILE.xlsm) :

View attachment 104804

Here is the 240111 SEARCH FILE.xlsx file with the value to found to send the column 3 result (UNIQUEID) in the column 3 of the Excel 240111 ASK FILE.xlsm file

View attachment 104806
Hope you can help with that ...

Thank you for your help !

Loadlucas
Click to expand...
try this:
VBA Code: 
Sub Inject2facteurs_test()
    Dim heureDebut As Double
    Dim sh As Worksheet, sho As Worksheet
    Dim wbs As String
    Dim fCol1A As Range, fCol2B As Range
    Dim c As Range
    heureDebut = Timer
    wbs = ActiveSheet.Range("G1").Value
    Set sh = Workbooks(wbs).Worksheets(1)
    Set sho = ThisWorkbook.Worksheets("Feuil1")
    For Each c In .Range("A1:A" & lr(sho, 1))
        Set fCol1A = CustomFind(c.Value, sh.Range("A1:A" & lr(sh, 1)))
        If Not fCol1A Is Nothing Then
            For Each fCol2B In fCol1A.Offset(, 1)
                If LCase(fCol2B.Value) = LCase(fCol2B.Offset(, -1).Value) Then c.Offset(, 2).Value = fCol2B.Offset(, 1).Value
            Next fCol2B
        End If
    Next c
    MsgBox "La macro a pris " & minutes & " minutes et " & Int(Timer - heureDebut) & " secondes.", vbInformation
End Sub

Private Function CustomFind(ByVal Criteria As String, ByVal Rng As Range) As Range
    Dim cll As Range
    For Each cll In Rng
        If LCase(CStr(cll.Value)) = LCase(Criteria) Then
            If CustomFind Is Nothing Then Set CustomFind = cll Else Set CustomFind = Union(CustomFind, cll)
        End If
    Next cll
End Function

Private Function lr(ByVal sh As Worksheet, ByVal cl As Integer) As Long
    lr = sh.Cells(Rows.Count, cl).End(xlUp).Row
End Function
 
Upvote 0
eiloken said:
try this:
VBA Code: 
Sub Inject2facteurs_test()
    Dim heureDebut As Double
    Dim sh As Worksheet, sho As Worksheet
    Dim wbs As String
    Dim fCol1A As Range, fCol2B As Range
    Dim c As Range
    heureDebut = Timer
    wbs = ActiveSheet.Range("G1").Value
    Set sh = Workbooks(wbs).Worksheets(1)
    Set sho = ThisWorkbook.Worksheets("Feuil1")
    For Each c In .Range("A1:A" & lr(sho, 1))
        Set fCol1A = CustomFind(c.Value, sh.Range("A1:A" & lr(sh, 1)))
        If Not fCol1A Is Nothing Then
            For Each fCol2B In fCol1A.Offset(, 1)
                If LCase(fCol2B.Value) = LCase(fCol2B.Offset(, -1).Value) Then c.Offset(, 2).Value = fCol2B.Offset(, 1).Value
            Next fCol2B
        End If
    Next c
    MsgBox "La macro a pris " & minutes & " minutes et " & Int(Timer - heureDebut) & " secondes.", vbInformation
End Sub

Private Function CustomFind(ByVal Criteria As String, ByVal Rng As Range) As Range
    Dim cll As Range
    For Each cll In Rng
        If Not IsEmpty(cll) And IsError(cll) Then
            If InStr(LCase(CStr(cll.Value)), LCase(Criteria)) Then
                If CustomFind Is Nothing Then Set CustomFind = cll Else Set CustomFind = Union(CustomFind, cll)
            End If
        End If
    Next cll
End Function

Private Function lr(ByVal sh As Worksheet, ByVal cl As Integer) As Long
    lr = sh.Cells(Rows.Count, cl).End(xlUp).Row
End Function
Click to expand...
Sorry maybe the code before has some mistaken, if what you need is value in column A and B of Search sheet match with column A and B of sheet 1 of file named as cell G1 in Search sheet then try this code:
VBA Code: 
Sub Inject2facteurs_test()
    Dim heureDebut As Double
    Dim sh As Worksheet, sho As Worksheet
    Dim wbs As String
    Dim fCol1A As Range, fCol2B As Range, xRng As Range, icll As Range
    Dim c As Range
    heureDebut = Timer
    wbs = ActiveSheet.Range("G1").Value
    Set sh = Workbooks(wbs).Worksheets(1)
    Set sho = ThisWorkbook.Worksheets("Feuil1")
    For Each c In sho.Range("A1:A" & lr(sho, 1))
        Set fCol1A = CustomFind(c.Value, sh.Range("A1:A" & lr(sh, 1)))
        If Not fCol1A Is Nothing Then
            Set fCol2B = CustomFind(c.Offset(, 1).Value, sh.Range("B1:B" & lr(sh, 2)))
            If Not fCol2B Is Nothing Then
                If Not Intersect(fCol1A, fCol2B.Offset(, -1)) Is Nothing Then Set xRng = Intersect(fCol1A, fCol2B.Offset(, -1))
                For Each icll In xRng
                    c.Offset(, 2).Value = icll.Offset(, 2).Value
                Next icll
            End If
        End If
    Next c
    MsgBox "La macro a pris " & minutes & " minutes et " & Int((Timer - heureDebut) / 60) & " secondes.", vbInformation
End Sub

Private Function CustomFind(ByVal Criteria As String, ByVal Rng As Range) As Range
    Dim cll As Range
    For Each cll In Rng
        If Not IsEmpty(cll) And IsError(cll) Then
            If InStr(LCase(CStr(cll.Value)), LCase(Criteria)) Then
                If CustomFind Is Nothing Then Set CustomFind = cll Else Set CustomFind = Union(CustomFind, cll)
            End If
        End If
    Next cll
End Function

Private Function lr(ByVal sh As Worksheet, ByVal cl As Integer) As Long
    lr = sh.Cells(Rows.Count, cl).End(xlUp).Row
End Function
 
Upvote 0
Hi
Thank you for the response
i tested the macro but no result was showed on the 3rd column
Any idea of the problem ?
Thank you.
 
Upvote 0
Loadlucas said:
Hi
Thank you for the response
i tested the macro but no result was showed on the 3rd column
Any idea of the problem ?
Thank you.
Click to expand...
try this:
VBA Code: 
Sub Inject2facteurs_test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim heureDebut As Double
    Dim sh As Worksheet, sho As Worksheet
    Dim wbs As String
    Dim fCol1A As Range, fCol2B As Range, xRng As Range, icll As Range
    Dim c As Range
    heureDebut = Timer
    Set sho = ThisWorkbook.Worksheets("Feuil1")
    sho.Range("C1:C" & lr(sho, 3)).ClearContents
    wbs = sho.Range("G1").Value
    Set sh = Workbooks(wbs).Worksheets(1)
    For Each c In sho.Range("A1:A" & lr(sho, 1))
        Set fCol1A = CustomFind(c.Value, sh.Range("A1:A" & lr(sh, 1)))
        If Not fCol1A Is Nothing Then
            Set fCol2B = CustomFind(c.Offset(, 1).Value, sh.Range("B1:B" & lr(sh, 2)))
            If Not fCol2B Is Nothing Then
                If Not Intersect(fCol1A, fCol2B.Offset(, -1)) Is Nothing Then Set xRng = Intersect(fCol1A, fCol2B.Offset(, -1))
                For Each icll In xRng
                    If IsEmpty(c.Offset(, 2)) Then
                        c.Offset(, 2).Value = icll.Offset(, 2).Value
                    Else
                        c.Offset(, 2).Value = c.Offset(, 2).Value & " ;" & icll.Offset(, 2).Value
                    End If
                Next icll
            End If
        End If
    Next c
    MsgBox "La macro a pris " & minutes & " minutes et " & Format(Timer - heureDebut, "0.000") & " secondes.", vbInformation
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Function CustomFind(ByVal Criteria As String, ByVal Rng As Range) As Range
    Dim cll As Range
    For Each cll In Rng
        If Not IsEmpty(cll) And Not IsError(cll) Then
            If InStr(LCase(CStr(cll.Value)), LCase(CStr(Criteria))) Then
                If CustomFind Is Nothing Then Set CustomFind = cll Else Set CustomFind = Union(CustomFind, cll)
            End If
        End If
    Next cll
End Function

Private Function lr(ByVal sh As Worksheet, ByVal cl As Integer) As Long
    lr = sh.Cells(Rows.Count, cl).End(xlUp).Row
End Function
 
Upvote 0
Hello
Thank you for your response.
There is an 424 VBA error at line :
VBA Code: 
For Each icll In xRng
I've checked the xRng variable that is =Nothing ... maybe this is the issue
Thank you
 
Upvote 0
Loadlucas said:
Hello
Thank you for your response.
There is an 424 VBA error at line :
VBA Code: 
For Each icll In xRng
I've checked the xRng variable that is =Nothing ... maybe this is the issue
Thank you
Click to expand...
ok, so change fisrt sub like this:
VBA Code: 
Sub Inject2facteurs_test()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim heureDebut As Double
    Dim sh As Worksheet, sho As Worksheet
    Dim wbs As String
    Dim fCol1A As Range, fCol2B As Range, xRng As Range, icll As Range
    Dim c As Range
    heureDebut = Timer
    Set sho = ThisWorkbook.Worksheets("Feuil1")
    sho.Range("C1:C" & lr(sho, 3)).ClearContents
    wbs = sho.Range("G1").Value
    Set sh = Workbooks(wbs).Worksheets(1)
    For Each c In sho.Range("A1:A" & lr(sho, 1))
        Set fCol1A = CustomFind(c.Value, sh.Range("A1:A" & lr(sh, 1)))
        If Not fCol1A Is Nothing Then
            Set fCol2B = CustomFind(c.Offset(, 1).Value, sh.Range("B1:B" & lr(sh, 2)))
            If Not fCol2B Is Nothing Then
                If Not Intersect(fCol1A, fCol2B.Offset(, -1)) Is Nothing Then
                    Set xRng = Intersect(fCol1A, fCol2B.Offset(, -1))
                    For Each icll In xRng
                        If IsEmpty(c.Offset(, 2)) Then
                            c.Offset(, 2).Value = icll.Offset(, 2).Value
                        Else
                            c.Offset(, 2).Value = c.Offset(, 2).Value & " ;" & icll.Offset(, 2).Value
                        End If
                    Next icll
                End If
            End If
        End If
    Next c
    MsgBox "La macro a pris " & minutes & " minutes et " & Format(Timer - heureDebut, "0.000") & " secondes.", vbInformation
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

F
  • Question Question
Error 1004 on VlookUp
Replies
5
Views
456
Anthony47
A
S
  • Question Question
Import cell value from another excel file
Replies
0
Views
485
sofas
S
N
  • Question Question
Relever mots-clés de fichiers Word vers un tableau Excel
Replies
3
Views
1K
nicolo9
N

Forum statistics

Threads
1,223,099
Messages
6,170,112
Members
452,302
Latest member
TaMere

Share this page

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
Back
Top