Retrouver les dimensions commune sur une feuille

[ascal44]

Bonsoir , j'ai un classeur avec différentes taille de joints classés pour plusieurs élément mécanique.
Sur une feuille je voudrais répertorier les joints de taille identique et indiquer leur provenance commune.



Je vous remercie pour votre aide

 

[jp14]

Re : Retrouver les dimensions commune sur une feuille

Bonsoir

Une procédure à tester

Sub recherchejoint()
Dim cellule As Range
Dim Sh As Worksheet
Dim dl1 As Long
With Sheets("Joints communs")
 For Each Sh In Worksheets
    If Sh.Name <> "Joints communs" Then
        For Each cellule In Sheets(Sh.Name).Range("b1:" & Sheets(Sh.Name).Cells.SpecialCells(xlCellTypeLastCell).Address)
            If InStr(UCase(cellule), "JOINT") > 0 Then
             dl1 = .Range("C" & .Rows.Count).End(xlUp).Row + 1
                .Range("c" & dl1) = Sh.Name
                .Range("d" & dl1) = cellule.Offset(0, -1)
                .Range("e" & dl1) = cellule.Offset(0, 0)
                .Range("f" & dl1) = cellule.Offset(0, 1)
                .Range("g" & dl1) = cellule.Offset(0, 2)
                .Range("h" & dl1) = cellule.Offset(0, 3)
                .Range("i" & dl1) = cellule.Offset(0, 4)
              End If
        Next cellule
    End If
Next Sh
End With
    
End Sub

En triant le tableau on détermine les joints identiques

JP

 

[ascal44]

Re : Retrouver les dimensions commune sur une feuille

Bonsoir , en fait il faudrait repérer les joints en doublons par leur 3 cotes ( Ø extérieur,Ø intérieur , hauteur/section ou largeur ).
Ces doublons les inscrire dans la feuille 'joints communs' en précisant en colonne C où l'on retrouve ces joints identiques.

 

[jp14]

Re : Retrouver les dimensions commune sur une feuille

Bonjour

Bonsoir , en fait il faudrait repérer les joints en doublons par leur 3 cotes ( Ø extérieur,Ø intérieur , hauteur/section ou largeur ).
Ces doublons les inscrire dans la feuille 'joints communs' en précisant en colonne C où l'on retrouve ces joints identiques.

Ci joint une procédure réalisant cette fonction

Option Explicit

Sub recherchejoint()
Dim cellule As Range
Dim Sh As Worksheet
Dim dl1 As Long
Dim d1 As Byte, d2 As Byte, d3 As Byte, d4 As Byte
With Sheets("Joints communs")

 For Each Sh In Worksheets
    If Sh.Name <> "Joints communs" Then
        For Each cellule In Sheets(Sh.Name).Range("b1:" & Sheets(Sh.Name).Cells.SpecialCells(xlCellTypeLastCell).Address)
            If InStr(UCase(cellule), "JOINT") > 0 Then
             dl1 = .Range("C" & .Rows.Count).End(xlUp).Row + 1
                .Range("c" & dl1) = Sh.Name
                .Range("d" & dl1) = cellule.Offset(0, -1)
                .Range("e" & dl1) = cellule.Offset(0, 0)
                .Range("f" & dl1) = cellule.Offset(0, 1)
                .Range("g" & dl1) = cellule.Offset(0, 2)
                .Range("h" & dl1) = cellule.Offset(0, 3)
                .Range("i" & dl1) = cellule.Offset(0, 4)
              End If
        Next cellule
    End If
Next Sh

dl1 = .Range("d" & Rows.Count).End(xlUp).Row

For Each cellule In .Range("d8:d" & dl1)
    d1 = Application.WorksheetFunction.CountIf(.Range("f8:d" & dl1), cellule.Offset(0, 2))
    d2 = Application.WorksheetFunction.CountIf(.Range("g8:d" & dl1), cellule.Offset(0, 3))
    d3 = Application.WorksheetFunction.CountIf(.Range("h8:d" & dl1), cellule.Offset(0, 4))
    d4 = Application.WorksheetFunction.CountIf(.Range("i8:d" & dl1), cellule.Offset(0, 5))
    
    If (d1 > 1 Or d1 = 0) And (d2 > 1 Or d2 = 0) And (d3 > 1 Or d3 = 0) And (d4 > 1 Or d4 = 0) Then
    Else
    cellule = ""
    End If
Next cellule
    For i = dl1 To 8 Step -1
    If .Range("d" & i) = "" Then .Rows(i).Delete Shift:=xlUp
    
    Next i
End With
    
End Sub

A tester

JP

 

[ascal44]

Re : Retrouver les dimensions commune sur une feuille

............