Menu

Regrouper deux macro en une!!!

nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 3 janv. 2018 à 11:14 - Dernière réponse : Patrice33740 6799 Messages postés dimanche 13 juin 2010Date d'inscription 19 avril 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 6799 Messages postés dimanche 13 juin 2010Date d'inscription 19 avril 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 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 4 janv. 2018 à 17:54
j'ai essayé mais rien changer
nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 5 janv. 2018 à 11:05
qlq'un peut m'aider?
Patrice33740 6799 Messages postés dimanche 13 juin 2010Date d'inscription 19 avril 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 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 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 6799 Messages postés dimanche 13 juin 2010Date d'inscription 19 avril 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