Regrouper deux macro en une!!!

nonossov 460 Messages postés lundi 29 décembre 2014Date d'inscription 8 janvier 2018 Dernière intervention - 3 janv. 2018 à 11:14 - Dernière réponse : Patrice33740 6476 Messages postés dimanche 13 juin 2010Date d'inscription 13 janvier 2018 Dernière intervention
- 8 janv. 2018 à 22:54
Bonjour,

je cherche a regrouper deux macros,
premieure c'est:

[/contents/446-fichier-sub Sub] Fusion_col()
'
' Macro1 Macro
'
Dim Col2 As String
Dim Col1 As String
Dim Separateur As String
Dim Vide As Long
Dim i As Single
Dim c As Range

Col1 = VBA.InputBox("Quelle est la lettre de la première colone?", "Colonne 1")
Col2 = VBA.InputBox("Quelle est la lettre de la deuxième colonne ?", "Colonne 2")
Separateur = VBA.InputBox("Quel séparateur voulez vous utiliser?", "Separateur")
'Col1 = Col1 + 0

Col1 = Col1 & ":" & Col1
'Col2 = Col2 & ":" & Col2

i = 1 'Numeros de col
Vide = 0  'limite de vide 100

Dim Temp As String
For Each c In ActiveSheet.Range(Col1).Cells
    If c.Text = "" Then
        'cellule vide
    Else
        Range(Col2 & i) = c.Text & Separateur & Range(Col2 & i).Text
    End If
    i = i + 1
    
Next

'MsgBox (vide)

    
'suppression de la colonne 1
Columns(Col1).Delete Shift:=xlToLeft
End Sub



La deuxieme:
Sub NETTOYAGE()
If MsgBox("Etes-vous sur de vouloir nettoyer le journal?", vbOKCancel) = vbCancel Then
    End
End If
   

 Dim sh As Worksheet
Dim ws As Worksheet
Dim a As Long
Dim b As Long

Set ws = Sheets("Input")
Set sh = Sheets("Output")

b = ws.Range("A1").End(xlDown).Row
c = sh.Range("A1").End(xlDown).Row
sh.Activate
sh.Range("A2", Cells(c, "I")).Clear
'sh.Range("A2", Cells(c, "I")).Interior.Color = RGB(255, 255, 255)
For a = 2 To b
sh.Cells(a, "C") = ws.Cells(a, "C")
sh.Cells(a, "A") = ws.Cells(a, "G")
sh.Cells(a, "E") = ws.Cells(a, "I")
sh.Cells(a, "B") = ws.Cells(a, "L")
sh.Cells(a, "G") = ws.Cells(a, "M")
sh.Cells(a, "D") = ws.Cells(a, "X")


Next
sh.Range("A2", Cells(b, "A")).NumberFormat = "dd/mm/yyyy;@"

Dim maplageC As Range

Set maplageC = sh.Range("G2", Cells(b, "G"))

For Each cellule In maplageC
  If cellule.Value > 0 Then
     sh.Cells(cellule.Row, 6).Value = "C"
  Else
    sh.Cells(cellule.Row, 6).Value = "D"
    
    End If

Next


Range("H2").Select
ActiveCell.FormulaR1C1 = "=MID(RC[-4],SEARCH("".TIF"",RC[-4])-8,8)"
Selection.Copy
Range("G60000").End(xlUp).Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("D2").Select
ActiveCell.FormulaR1C1 = "=RC[4]"
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Columns("H:H").ClearContents
Columns("D:D").EntireColumn.AutoFit
Range("A2").Select


Columns("A:G").Select
Selection.AutoFilter
ActiveSheet.Range("$A:$G").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
Range("G60000").End(xlUp).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
Selection.Copy
Range(Selection, Range("H2")).Select
ActiveSheet.Paste
Selection.AutoFilter

Columns("H:H").Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

ActiveSheet.Range("$A:$H").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
        
Columns("G:G").SpecialCells(xlCellTypeVisible).ClearContents
Selection.AutoFilter






End Sub
    
    
    
    
Sub test()

Columns("A:G").Select
Selection.AutoFilter
ActiveSheet.Range("$A:$G").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
Range("G60000").End(xlUp).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
Selection.Copy
Range(Selection, Range("H2")).Select
ActiveSheet.Paste
Selection.AutoFilter

Columns("H:H").Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

ActiveSheet.Range("$A:$H").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
        
Columns("G:G").SpecialCells(xlCellTypeVisible).ClearContents
Selection.AutoFilter



End Sub




Merci infiniment
Afficher la suite 

11 réponses

Répondre au sujet
Patrice33740 6476 Messages postés dimanche 13 juin 2010Date d'inscription 13 janvier 2018 Dernière intervention - 3 janv. 2018 à 11:35
0
Utile
10
NB : Quand tu postes du code sur le forum, utiliser les balises c'est bien,
mais avec indication du langage (=coloration syntaxique) c'est mieux
Explications disponibles ici : Comment utiliser les balises de code
Exemple :
Sub UtiliserLesBalises()
  MsgBox "Merci d'utiliser les balises de code"
End Sub

nonossov 460 Messages postés lundi 29 décembre 2014Date d'inscription 8 janvier 2018 Dernière intervention - 4 janv. 2018 à 17:54
j'ai essayé mais rien changer
nonossov 460 Messages postés lundi 29 décembre 2014Date d'inscription 8 janvier 2018 Dernière intervention - 5 janv. 2018 à 11:05
qlq'un peut m'aider?
Patrice33740 6476 Messages postés dimanche 13 juin 2010Date d'inscription 13 janvier 2018 Dernière intervention - 5 janv. 2018 à 14:34
Peut-être, si donnes des explications claires et détaillées de ce que tu as essayé et de ce que tu voudrais obtenir ....
nonossov 460 Messages postés lundi 29 décembre 2014Date d'inscription 8 janvier 2018 Dernière intervention - 8 janv. 2018 à 18:41
je pense c'est claire voila les deux macros, svp essayer de les regrouper ensemble car j'ai essayé mais je n'ai pas reussi:

[/contents/446-fichier-sub Sub] Fusion_col()
'
' Macro1 Macro
'
Dim Col2 As String
Dim Col1 As String
Dim Separateur As String
Dim Vide As Long
Dim i As Single
Dim c As Range

Col1 = VBA.InputBox("Quelle est la lettre de la première colone?", "Colonne 1")
Col2 = VBA.InputBox("Quelle est la lettre de la deuxième colonne ?", "Colonne 2")
Separateur = VBA.InputBox("Quel séparateur voulez vous utiliser?", "Separateur")
'Col1 = Col1 + 0

Col1 = Col1 & ":" & Col1
'Col2 = Col2 & ":" & Col2

i = 1 'Numeros de col
Vide = 0  'limite de vide 100

Dim Temp As String
For Each c In ActiveSheet.Range(Col1).Cells
    If c.Text = "" Then
        'cellule vide
    Else
        Range(Col2 & i) = c.Text & Separateur & Range(Col2 & i).Text
    End If
    i = i + 1
    
Next

'MsgBox (vide)

    
'suppression de la colonne 1
Columns(Col1).Delete Shift:=xlToLeft
End Sub



Deuxieme:

Sub NETTOYAGE()
If MsgBox("Etes-vous sur de vouloir nettoyer le journal?", vbOKCancel) = vbCancel Then
    End
End If
   

 Dim sh As Worksheet
Dim ws As Worksheet
Dim a As Long
Dim b As Long

Set ws = Sheets("Input")
Set sh = Sheets("Output")

b = ws.Range("A1").End(xlDown).Row
c = sh.Range("A1").End(xlDown).Row
sh.Activate
sh.Range("A2", Cells(c, "I")).Clear
'sh.Range("A2", Cells(c, "I")).Interior.Color = RGB(255, 255, 255)
For a = 2 To b
sh.Cells(a, "C") = ws.Cells(a, "C")
sh.Cells(a, "A") = ws.Cells(a, "G")
sh.Cells(a, "E") = ws.Cells(a, "I")
sh.Cells(a, "B") = ws.Cells(a, "L")
sh.Cells(a, "G") = ws.Cells(a, "M")
sh.Cells(a, "D") = ws.Cells(a, "X")


Next
sh.Range("A2", Cells(b, "A")).NumberFormat = "dd/mm/yyyy;@"

Dim maplageC As Range

Set maplageC = sh.Range("G2", Cells(b, "G"))

For Each cellule In maplageC
  If cellule.Value > 0 Then
     sh.Cells(cellule.Row, 6).Value = "C"
  Else
    sh.Cells(cellule.Row, 6).Value = "D"
    
    End If

Next


Range("H2").Select
ActiveCell.FormulaR1C1 = "=MID(RC[-4],SEARCH("".TIF"",RC[-4])-8,8)"
Selection.Copy
Range("G60000").End(xlUp).Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Range("D2").Select
ActiveCell.FormulaR1C1 = "=RC[4]"
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Columns("H:H").ClearContents
Columns("D:D").EntireColumn.AutoFit
Range("A2").Select


Columns("A:G").Select
Selection.AutoFilter
ActiveSheet.Range("$A:$G").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
Range("G60000").End(xlUp).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
Selection.Copy
Range(Selection, Range("H2")).Select
ActiveSheet.Paste
Selection.AutoFilter

Columns("H:H").Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

ActiveSheet.Range("$A:$H").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
        
Columns("G:G").SpecialCells(xlCellTypeVisible).ClearContents
Selection.AutoFilter






End Sub
    
    
    
    
Sub test()

Columns("A:G").Select
Selection.AutoFilter
ActiveSheet.Range("$A:$G").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
Range("G60000").End(xlUp).Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=RC[-1]"
Selection.Copy
Range(Selection, Range("H2")).Select
ActiveSheet.Paste
Selection.AutoFilter

Columns("H:H").Copy
Range("H1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

ActiveSheet.Range("$A:$H").AutoFilter Field:=7, Criteria1:=">0", Operator:=xlAnd
        
Columns("G:G").SpecialCells(xlCellTypeVisible).ClearContents
Selection.AutoFilter



End Sub
Patrice33740 6476 Messages postés dimanche 13 juin 2010Date d'inscription 13 janvier 2018 Dernière intervention - 8 janv. 2018 à 22:54
Coment veux-tu qu'on t'aide si tu ne donnes aucune explications !!!

1) Je t'ai donné une solution simple : ajouter au début (ou à la fin selon ce que te veux) de ta première macro : Call NETTOYAGE
Tu réponds juste : j'ai essayé mais rien changer
Effectivement si tu n'a rien changé ça risque pas de fonctionner !!!

2) Ce qui n'est pas clair, c'est « je cherche a regrouper deux macros »
Ces macros sont indépendantes, elles n'ont rien à voir l'une avec l'autre donc il faut que tu précises ce que t'entends tu par regrouper ? En français, regrouper, c'est mettre côte à côte.
Commenter la réponse de Patrice33740