Sujet Précédent

Macro nomenclature catia vers excel

mike7182 Messages postés 6 Date d'inscription jeudi 7 décembre 2023 Statut Membre Dernière intervention 30 octobre 2024 - 29 oct. 2024 à 13:03
yg_be Messages postés 23301 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 30 octobre 2024 - 30 oct. 2024 à 17:43

bonjour je suis débutant en vba, j'essai de faire une macro qui m'exporte une nomenclature catia vers excel (voir mise image mise en forme) mais toutes mes opérations ne sont pas prises en compte pourriez-vous me dire où je fais une erreur

-- macro catia --
Sub CATMain()

' Vérifier si le document actif est un CATProduct

On Error Resume Next
Set myDocument = CATIA.ActiveDocument
If Err.Number <> o Then
    MsgBox "Il n'y a pas de fichier ouvert dans CATIA", vbCritical, "Erreur"
    End
End If
If TypeName(myDocument) <> "ProductDocument" Then
    MsgBox "Le document actif doit être un CATProduct", vbCritical, "Erreur"
    End
End If
Set myProduct = myDocument.Product


' export bill of material

Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument

Dim product1 As Product
Set product1 = productDocument1.Product

Dim assemblyConvertor1 As AssemblyConvertor
Set assemblyConvertor1 = product1.GetItem("BillOfMaterial")

Dim arrayOfVariantOfBSTR5(11)
arrayOfVariantOfBSTR5(0) = "Quantité"
arrayOfVariantOfBSTR5(1) = "Type"
arrayOfVariantOfBSTR5(2) = "Référence"
arrayOfVariantOfBSTR5(3) = "Révision"
arrayOfVariantOfBSTR5(4) = "Définition"
arrayOfVariantOfBSTR5(5) = "Nomenclature"
arrayOfVariantOfBSTR5(6) = "Source"
arrayOfVariantOfBSTR5(7) = "MASS"
arrayOfVariantOfBSTR5(8) = "MATIERE"
arrayOfVariantOfBSTR5(9) = "ARTICLE"
arrayOfVariantOfBSTR5(10) = "FOURNISSEUR"
Set assemblyConvertor1Variant = assemblyConvertor1
assemblyConvertor1Variant.SetCurrentFormat arrayOfVariantOfBSTR5

Dim arrayOfVariantOfBSTR6(11)
aarrayOfVariantOfBSTR6(0) = "Quantité"
arrayOfVariantOfBSTR6(1) = "Type"
arrayOfVariantOfBSTR6(2) = "Référence"
arrayOfVariantOfBSTR6(3) = "Révision"
arrayOfVariantOfBSTR6(4) = "Définition"
arrayOfVariantOfBSTR6(5) = "Nomenclature"
arrayOfVariantOfBSTR6(6) = "Source"
arrayOfVariantOfBSTR6(7) = "MASS"
arrayOfVariantOfBSTR6(8) = "MATIERE"
arrayOfVariantOfBSTR6(9) = "ARTICLE"
arrayOfVariantOfBSTR6(10) = "FOURNISSEUR"
Set assemblyConvertor1Variant = assemblyConvertor1
assemblyConvertor1Variant.SetSecondaryFormat arrayOfVariantOfBSTR6

assemblyConvertor1.[Print] "XLS", "C:\Temp\export.xls", product1

 Set wb = ExcelApp.Workbook.Open(chemin)

Dim ExcelApp As Object
Dim Workbook As Object
Dim CheminFichier As String
Dim cheminfichier2 As String

' Spécifiez le chemin complet de votre fichier Excel
CheminFichier = "C:\Temp\export.xls"
cheminfichier2 = "C:\Temp\modifexcel.xlsm"

' Créer une instance d'Excel
Set ExcelApp = CreateObject("Excel.Application")

' Rendre Excel visible (optionnel)
ExcelApp.Visible = True

' Ouvrir le fichier Excel
Set Workbook = ExcelApp.Workbooks.Open(CheminFichier)
Set Workbook = ExcelApp.Workbooks.Open(cheminfichier2)
 
' Exécuter une macro du classeur ouvert
objExcel.Run "bommodif"

End Sub

-- macro excel-- 
Sub bommodif()
'
' bommodif Macro
'
'
Dim condition1 As String
Dim condition2 As String
Dim condition3 As String
Dim condition4 As String
Dim condition5 As String
Dim motrecherche As String
Dim motrecherche2 As String
Dim resultat As String
Dim trouve As Boolean
Dim debut As Range
Dim cell As Range
Dim foundcell As Range
Dim foundcell2 As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim a As Long
Dim b As Long
Dim ligne As Long
Dim lastrowsource As Long
Dim lastrowdestination As Long
Dim lastrowdestination2 As Long
Dim wbsource As Worksheet
Dim wbdestionation As Worksheet
Dim dict As Object
Dim dict2 As Object

Dim sourceworkbook As Workbook
Dim sourcesheet As Worksheet
Dim destinationworkbook As Workbook
Dim destinationsheet As Worksheet
Dim destinationsheet2 As Worksheet

' copier les données de export.xls à ce fichier

    Set sourceworkbook = Workbooks.Open("C:\temp\export.xls")
    Set sourcesheet = sourceworkbook.Feuil1
    Set destinationworkbook = Workbooks.Open("C:\temp\modifexcel.xlsm")
    Set destinationsheet = destinationworkbook.Feuil1
    sourcesheet.UsedRange.Copy destinationsheet.Range("A1")
    sourceworkbook.Close
        

' créer une nouvelle feuille dans classeur "modifexcel"

destinationworkbook.Select
nomfeuille = "feuil2"
On Error Resume Next
Set destinationworkbook = Workbooks.Open("C:\temp\modifexcel.xlsm")
Set destinationsheet2 = destinationworkbook.Sheets(nomfeuille)
On Error GoTo 0
If destinationsheet2 Is Nothing Then
    Set destinationsheet2 = destinationworkbook.Sheets.Add(After:=destinationworkbook.Sheets(destinationworkbook.Sheets.Count))
    destinationsheet2.Name = nomfeuille
    End If
    
' effacer les données et la mise en forme éventuelle de la feuille 2
    
      Sheets("feuil2").Select
      Cells.Select
      Selection.ClearContents
      With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
        
' copier coller des titres des colonnes

    Sheets("feuil1").Select
    Range("A4:K4").Select
    Selection.Copy
    Sheets("Feuil2").Select
    Range("A2").Select
    ActiveSheet.Paste
    
' mise en forme du tableau (largeur, texte centré)

    Range("A:A,B:B,D:D,G:G,H:H").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("C2,E2,F2,I2,J2,K2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("A:A,D:D,G:G,H:H").Select
    Selection.ColumnWidth = 8
    Range("F:F,I:I,J:J,K:K").Select
    Selection.ColumnWidth = 30
    Columns("B:B").Select
    Selection.ColumnWidth = 12
    Columns("C:C").Select
    Selection.ColumnWidth = 40
    Columns("E:E").Select
    Selection.ColumnWidth = 45
    Range("A2:K2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With
    
' ajout de la ligne titre pour les assemblages
    
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "ASSEMBLAGE"
    Range("A3:K3").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.NumberFormat = "@"
    Range("A3:K3").Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
' copier coller les données concernant les assemblages avec condition "assemblage"
    
    condition1 = "Assemblage"
    
    Set wbsource = Sheets("feuil1")
    lastrowsource = wbsource.Cells(Rows.Count, 1).End(xlUp).Row
    Set wbdestination = Sheets("feuil2")

    lastrowdestination = 4
    
    For i = 1 To lastrowsource
        If wbsource.Cells(i, 2).Value = condition1 Then
          wbsource.Rows(i).Copy wbdestination.Rows(lastrowdestination)
     lastrowdestination = lastrowdestination + 1
     End If
     Next i
     
' ajout de la ligne titre pour les "pièces fabriquées" avec prise en compte du nombre aléatoire de lignes ajoutées pour les assemblages
     
     a = wbdestination.Cells(Rows.Count, 1).End(xlUp).Row
     
     
    Cells(a + 1, 1).Select
    ActiveCell.FormulaR1C1 = "PIECE FABRIQUEE"
    Range(Cells(a + 1, 1), Cells(a + 1, 11)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.NumberFormat = "@"
    Range(Cells(a + 1, 1), Cells(a + 1, 11)).Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
       
    
' copier coller les données "piéces fabriquées" avec recherche depuis un mot clef et conditions "pièces" "fabriquées"

    motrecherche = "Récapitulatif"
    condition2 = "Pièce"
    condition3 = "Fabriqué"
    lastrowdestination = lastrowdestination + 1
    Set dict = CreateObject("scripting.dictionary")
    Set foundcell = wbsource.Columns(1).Find(motcherche, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not foundcell Is Nothing Then
    
    For j = foundcell.Row To lastrowsource
        
                If wbsource.Cells(j, 2).Value Like condition2 And wbsource.Cells(j, 7).Value Like condition3 Then
                Dim key As String
                key = wbsource.Cells(j, 3).Value & "|"
                If Not dict.exists(key) Then
                dict.Add key, Nothing
                    wbsource.Rows(j).Copy wbdestination.Rows(lastrowdestination)
                    lastrowdestination = lastrowdestination + 1
                End If
                End If
            Next j
        End If

             
' ajout de la ligne titre pour les "pièces achetées" avec prise en compte du nombre aléatoire de lignes ajoutées pour les pièces fabriquées
     
     b = wbdestination.Cells(Rows.Count, 1).End(xlUp).Row

     
    Cells(b + 1, 1).Select
    ActiveCell.FormulaR1C1 = "PIECE ACHETEE"
    Range(Cells(b + 1, 1), Cells(b + 1, 11)).Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.NumberFormat = "@"
    Range(Cells(b + 1, 1), Cells(b + 1, 11)).Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
       
    
' copier coller les données "piéces achetées" avec recherche depuis un mot clef et conditions "pièces" "achetées"

    motrecherche = "Récapitulatif"
    condition2 = "Pièce"
    condition4 = "Acheté"
    lastrowdestination = lastrowdestination + 1
    Set dict = CreateObject("scripting.dictionary")
    Set foundcell = wbsource.Columns(1).Find(motcherche, LookIn:=xlValues, LookAt:=xlWhole)
    
    If Not foundcell Is Nothing Then
    
    For j = foundcell.Row To lastrowsource
        
                If wbsource.Cells(j, 2).Value Like condition2 And wbsource.Cells(j, 7).Value Like condition4 Then
                Dim key2 As String
                key2 = wbsource.Cells(j, 3).Value & "|"
                If Not dict.exists(key) Then
                dict.Add key, Nothing
                    wbsource.Rows(j).Copy wbdestination.Rows(lastrowdestination)
                    lastrowdestination = lastrowdestination + 1
                End If
                End If
            Next j
        End If
    
End Sub
A voir également:

5 réponses

Réponse 1 / 5
luckydu43 Messages postés 3824 Date d'inscription vendredi 9 janvier 2015 Statut Membre Dernière intervention 30 octobre 2024 951
Modifié le 29 oct. 2024 à 16:45

Bonjour

Déjà, faites à minima un effort de relecture du post, sans plugin de réindentation de code sur un éditeur de texte tiers, c'est vite un problème !

C'est ILLISIBLE sur cette page.

Je ne me suis concentré que sur la fonction CATMain() et il y a déjà des choses à revoir. La macro est tellement dense que je laisse les autres helpers motivés s'y coller ^^'

Voici ma relecture de la fonction.

-- macro catia --
Sub CATMain()
    ' Vérifier si le document actif est un CATProduct
    On Error Resume Next
    Set myDocument = CATIA.ActiveDocument
    If Err.Number <> 0 Then
        MsgBox "Il n'y a pas de fichier ouvert dans CATIA", vbCritical, "Erreur"
        End
    End If
    If TypeName(myDocument) <> "ProductDocument" Then
        MsgBox "Le document actif doit être un CATProduct", vbCritical, "Erreur"
        End
    End If
    Set myProduct = myDocument.Product

    ' export bill of material
    Dim productDocument1 As ProductDocument
    Set productDocument1 = CATIA.ActiveDocument
    Dim product1 As Product
    Set product1 = productDocument1.Product
    Dim assemblyConvertor1 As AssemblyConvertor
    Set assemblyConvertor1 = product1.GetItem("BillOfMaterial")

	'#####################################################################################
	' Dim arrayOfVariantOfBSTR5(11) réserve un tableau de 12 éléments, il compte bien le 0
	' Utilisation de 0 To 10 pour plus de clarté de code
	'#####################################################################################
    Dim arrayOfVariantOfBSTR5(0 To 10)
    arrayOfVariantOfBSTR5(0) = "Quantité"
    arrayOfVariantOfBSTR5(1) = "Type"
    arrayOfVariantOfBSTR5(2) = "Référence"
    arrayOfVariantOfBSTR5(3) = "Révision"
    arrayOfVariantOfBSTR5(4) = "Définition"
    arrayOfVariantOfBSTR5(5) = "Nomenclature"
    arrayOfVariantOfBSTR5(6) = "Source"
    arrayOfVariantOfBSTR5(7) = "MASS"
    arrayOfVariantOfBSTR5(8) = "MATIERE"
    arrayOfVariantOfBSTR5(9) = "ARTICLE"
    arrayOfVariantOfBSTR5(10) = "FOURNISSEUR"

	'#####################################################################################
    ' Définir la taille de assemblyConvertor1Variant
	'#####################################################################################
    Dim assemblyConvertor1Variant As Variant
    Set assemblyConvertor1Variant = assemblyConvertor1
    assemblyConvertor1Variant.SetCurrentFormat arrayOfVariantOfBSTR5

    '#####################################################################################
	' Dim arrayOfVariantOfBSTR5(11) réserve un tableau de 12 éléments, il compte bien le 0
	' Utilisation de 0 To 10 pour plus de clarté de code
	'#####################################################################################
    Dim arrayOfVariantOfBSTR6(0 To 10)
    arrayOfVariantOfBSTR6(0) = "Quantité"
    arrayOfVariantOfBSTR6(1) = "Type"
    arrayOfVariantOfBSTR6(2) = "Référence"
    arrayOfVariantOfBSTR6(3) = "Révision"
    arrayOfVariantOfBSTR6(4) = "Définition"
    arrayOfVariantOfBSTR6(5) = "Nomenclature"
    arrayOfVariantOfBSTR6(6) = "Source"
    arrayOfVariantOfBSTR6(7) = "MASS"
    arrayOfVariantOfBSTR6(8) = "MATIERE"
    arrayOfVariantOfBSTR6(9) = "ARTICLE"
    arrayOfVariantOfBSTR6(10) = "FOURNISSEUR"

    '#####################################################################################
    ' SetSecondaryFormat redéfinit déjà assemblyConvertor1Variant
    '#####################################################################################
    assemblyConvertor1Variant.SetSecondaryFormat arrayOfVariantOfBSTR6

    '#####################################################################################
    ' Print est une fonction
    '#####################################################################################
    assemblyConvertor1.Print "XLS", "C:\Temp\export.xls", product1


    '#####################################################################################
    ' Set wb = ExcelApp.Workbook.Open(chemin)
	' wb n'est jamais utilisé
    '#####################################################################################
    Dim ExcelApp As Object
    Dim Workbook As Object
    '#####################################################################################
    ' Dim CheminFichier As String n'est jamais utilisé, voir ligne 100
	' Attention à la casse, il y a CheminFichier et cheminfichier pour 2 variables similaires !
    '#####################################################################################
    Dim cheminfichier2 As String

    ' Spécifiez le chemin complet de votre fichier Excel
    CheminFichier = "C:\Temp\export.xls"
    cheminfichier2 = "C:\Temp\modifexcel.xlsm"

    ' Créer une instance d'Excel
    Set ExcelApp = CreateObject("Excel.Application")

    ' Rendre Excel visible (optionnel)
    ExcelApp.Visible = True

    ' Ouvrir le fichier Excel
    '#####################################################################################
    ' Set Workbook = ExcelApp.Workbooks.Open(CheminFichier)
	' Cette ligne est inutile, Workbook est redéfini immédiatement
	'#####################################################################################
    Set Workbook = ExcelApp.Workbooks.Open(cheminfichier2)

    ' Exécuter une macro du classeur ouvert
	'#####################################################################################
	' objExcel n'est défini nulle part ici
	'#####################################################################################
    ExcelApp.Run "bommodif"
End Sub

Pour les motivés, voici une version indentée de la macro.

-- macro excel--
Sub bommodif()
    ' bommodif Macro

    Dim condition1 As String
    Dim condition2 As String
    Dim condition3 As String
    Dim condition4 As String
    Dim condition5 As String
    Dim motrecherche As String
    Dim motrecherche2 As String
    Dim resultat As String
    Dim trouve As Boolean
    Dim debut As Range
    Dim cell As Range
    Dim foundcell As Range
    Dim foundcell2 As Range
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim a As Long
    Dim b As Long
    Dim ligne As Long
    Dim lastrowsource As Long
    Dim lastrowdestination As Long
    Dim lastrowdestination2 As Long
    Dim wbsource As Worksheet
    Dim wbdestionation As Worksheet
    Dim dict As Object
    Dim dict2 As Object
    Dim sourceworkbook As Workbook
    Dim sourcesheet As Worksheet
    Dim destinationworkbook As Workbook
    Dim destinationsheet As Worksheet
    Dim destinationsheet2 As Worksheet

    ' copier les données de export.xls à ce fichier
    Set sourceworkbook = Workbooks.Open("C:\temp\export.xls")
    Set sourcesheet = sourceworkbook.Feuil1
    Set destinationworkbook = Workbooks.Open("C:\temp\modifexcel.xlsm")
    Set destinationsheet = destinationworkbook.Feuil1
    sourcesheet.UsedRange.Copy destinationsheet.Range("A1")
    sourceworkbook.Close

    ' créer une nouvelle feuille dans classeur "modifexcel"
    destinationworkbook.Select
    nomfeuille = "feuil2"
    On Error Resume Next
    Set destinationworkbook = Workbooks.Open("C:\temp\modifexcel.xlsm")
    Set destinationsheet2 = destinationworkbook.Sheets(nomfeuille)
    On Error GoTo 0
    If destinationsheet2 Is Nothing Then
        Set destinationsheet2 = destinationworkbook.Sheets.Add(After:=destinationworkbook.Sheets(destinationworkbook.Sheets.Count))
        destinationsheet2.Name = nomfeuille
    End If

    ' effacer les données et la mise en forme éventuelle de la feuille 2
    Sheets("feuil2").Select
    Cells.Select
    Selection.ClearContents

    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    ' copier coller des titres des colonnes
    Sheets("feuil1").Select
    Range("A4:K4").Select
    Selection.Copy
    Sheets("Feuil2").Select
    Range("A2").Select
    ActiveSheet.Paste

    ' mise en forme du tableau (largeur, texte centré)
    Range("A:A,B:B,D:D,G:G,H:H").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Range("C2,E2,F2,I2,J2,K2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    Range("A:A,D:D,G:G,H:H").Select
    Selection.ColumnWidth = 8
    Range("F:F,I:I,J:J,K:K").Select
    Selection.ColumnWidth = 30
    Columns("B:B").Select
    Selection.ColumnWidth = 12
    Columns("C:C").Select
    Selection.ColumnWidth = 40
    Columns("E:E").Select
    Selection.ColumnWidth = 45
    Range("A2:K2").Select

    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0.799981688894314
        .PatternTintAndShade = 0
    End With

    ' ajout de la ligne titre pour les assemblages
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "ASSEMBLAGE"
    Range("A3:K3").Select

    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With

    Selection.NumberFormat = "@"
    Range("A3:K3").Select

    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

    ' copier coller les données concernant les assemblages avec condition "assemblage"
    condition1 = "Assemblage"
    Set wbsource = Sheets("feuil1")
	lastrowsource = wbsource.Cells(Rows.Count, 1).End(xlUp).Row
	Set wbdestination = Sheets("feuil2")
	lastrowdestination = 4

	For i = 1 To lastrowsource
		If wbsource.Cells(i, 2).Value = condition1 Then
			wbsource.Rows(i).Copy wbdestination.Rows(lastrowdestination)
			lastrowdestination = lastrowdestination + 1
		End If
	Next i

	' ajout de la ligne titre pour les "pièces fabriquées" avec prise en compte du nombre aléatoire de lignes ajoutées pour les assemblages
	a = wbdestination.Cells(Rows.Count, 1).End(xlUp).Row
	Cells(a + 1, 1).Select
	ActiveCell.FormulaR1C1 = "PIECE FABRIQUEE"
	Range(Cells(a + 1, 1), Cells(a + 1, 11)).Select

	With Selection.Interior
		.Pattern = xlSolid
		.PatternColorIndex = xlAutomatic
		.Color = 65535
		.TintAndShade = 0
		.PatternTintAndShade = 0
	End With

	Selection.NumberFormat = "@"
	Range(Cells(a + 1, 1), Cells(a + 1, 11)).Select

	With Selection
		.HorizontalAlignment = xlCenterAcrossSelection
		.VerticalAlignment = xlBottom
		.WrapText = False
		.Orientation = 0
		.AddIndent = False
		.IndentLevel = 0
		.ShrinkToFit = False
		.ReadingOrder = xlContext
		.MergeCells = False
	End With

	' copier coller les données "piéces fabriquées" avec recherche depuis un mot clef et conditions "pièces" "fabriquées"
	motrecherche = "Récapitulatif"
	condition2 = "Pièce"
	condition3 = "Fabriqué"
	lastrowdestination = lastrowdestination + 1
	Set dict = CreateObject("scripting.dictionary")
	Set foundcell = wbsource.Columns(1).Find(motcherche, LookIn:=xlValues, LookAt:=xlWhole)

	If Not foundcell Is Nothing Then
		For j = foundcell.Row To lastrowsource
			If wbsource.Cells(j, 2).Value Like condition2 And wbsource.Cells(j, 7).Value Like condition3 Then
				Dim key As String
				key = wbsource.Cells(j, 3).Value & "|"
				If Not dict.exists(key) Then
					dict.Add key, Nothing
					wbsource.Rows(j).Copy wbdestination.Rows(lastrowdestination)
					lastrowdestination = lastrowdestination + 1
				End If
			End If
		Next j
	End If

	' ajout de la ligne titre pour les "pièces achetées" avec prise en compte du nombre aléatoire de lignes ajoutées pour les pièces fabriquées
	b = wbdestination.Cells(Rows.Count, 1).End(xlUp).Row
	Cells(b + 1, 1).Select
	ActiveCell.FormulaR1C1 = "PIECE ACHETEE"
	Range(Cells(b + 1, 1), Cells(b + 1, 11)).Select

	With Selection.Interior
		.Pattern = xlSolid
		.PatternColorIndex = xlAutomatic
		.Color = 65535
		.TintAndShade = 0
		.PatternTintAndShade = 0
	End With

	Selection.NumberFormat = "@"
	Range(Cells(b + 1, 1), Cells(b + 1, 11)).Select

	With Selection
		.HorizontalAlignment = xlCenterAcrossSelection
		.VerticalAlignment = xlBottom
		.WrapText = False
		.Orientation = 0
		.AddIndent = False
		.IndentLevel = 0
		.ShrinkToFit = False
		.ReadingOrder = xlContext
		.MergeCells = False
	End With

	' copier coller les données "piéces achetées" avec recherche depuis un mot clef et conditions "pièces" "achetées"
	motrecherche = "Récapitulatif"
	condition2 = "Pièce"
	condition4 = "Acheté"
	lastrowdestination = lastrowdestination + 1
	Set dict = CreateObject("scripting.dictionary")
	Set foundcell = wbsource.Columns(1).Find(motrecherche, LookIn:=xlValues, LookAt:=xlWhole)

	If Not foundcell Is Nothing Then
		For j = foundcell.Row To lastrowsource
			If wbsource.Cells(j, 2).Value Like condition2 And wbsource.Cells(j, 7).Value Like condition4 Then
				Dim key2 As String
				key2 = wbsource.Cells(j, 3).Value & "|"
				If Not dict.exists(key2) Then
					dict.Add key2, Nothing
					wbsource.Rows(j).Copy wbdestination.Rows(lastrowdestination)
					lastrowdestination = lastrowdestination + 1
				End If
			End If
		Next j
	End If
End Sub
0
Réponse 2 / 5
yg_be Messages postés 23301 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 30 octobre 2024 Ambassadeur 1 549
30 oct. 2024 à 09:41

bonjour,

peux-tu partager ton fichier, et préciser les divergences entre ce que tu obtiens et ce que tu attends?
0
Réponse 3 / 5
mike7182 Messages postés 6 Date d'inscription jeudi 7 décembre 2023 Statut Membre Dernière intervention 30 octobre 2024 1
30 oct. 2024 à 13:28

bonjour
merci a luckydu43 pour ta réponse, désolé si mon post est imbuvable ce n'est que la deuxième fois que j'utilise ce site et j'ai fait un simple copier/coller de mes macros
 

yg_be comment je fait pour te partager mon fichier ?
0
Réponse 4 / 5
mariam-j Messages postés 1339 Date d'inscription mercredi 9 mars 2022 Statut Membre Dernière intervention 30 octobre 2024 10
30 oct. 2024 à 13:36

Bonjour,

Tu peux le mettre sur "Cjoint" et coller dans ta réponse le lien que tu aura demandé

  https://www.cjoint.com/
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 5
mike7182 Messages postés 6 Date d'inscription jeudi 7 décembre 2023 Statut Membre Dernière intervention 30 octobre 2024 1
30 oct. 2024 à 13:49

https://www.cjoint.com/c/NJEmSMmakXX

En fait je suis parti de catia v5 d'un product, j'ai générer une bill of material que j'ai enregistrer en export.xls de la j'ai créer une macro qui me permet de compiler les données sous un tableau ordonné.

mais quand je lance la macro dans catia rien ne se passe dans mon fichier excel

ce que j'aimerai obtenir se trouve sur la feuille 2 du fichier excel "ess11.xlsm"
0
yg_be Messages postés 23301 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 30 octobre 2024 1 549
30 oct. 2024 à 17:43

Au début, tu as écrit "toutes mes opérations ne sont pas prises en compte".

Je comprends donc que certaines sont prises en compte.  Lesquelles?

Maintenant, tu écris "rien ne se passe".  

Si je comprends bien, ta macro ne fonctionne pas du tout, et tu n'expliques pas ce que tu souhaites qu'elle fasse.

0

Discussions similaires

Colis en cours de transport vers votre site de livraison ?
Ninan_5568 -
JulieVdr -

7 réponses
Transformer un chiffre en lettres dans excel sans macro
vincentphilippos -
tontong -

6 réponses