Menu

Changer la feuille de travail excel

nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 5 déc. 2017 à 10:56 - Dernière réponse : nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention
- 5 janv. 2018 à 11:05
Bonjour mes chers amis;

Je viens de finir une macro qui travaille sur deux feuils spécifiques:

input: c'est ou j'ai les données.
Output: c'est ou je recois le résultat final.

j'ai essayé de rendre la macro exploitable sur un seul feuil:
doc je dois recevoir le résultat dans le même feuil: Input.

Voilà le message que je recois après quelques essaye;

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



Le code Macro:

Sub NETTOYAGE()
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

Columns("G:G").Select
Selection.Replace What:="-", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

Range("A60000").End(xlUp).Offset(0, 8).Select
Selection = "E"
Selection.Copy
Range(Selection, Range("I2")).Select
ActiveSheet.Paste

Application.CutCopyMode = False








End Sub
    
    
    
    
Sub test()



End Sub







EDIT : Ajout des balises de code (la coloration syntaxique).
Explications disponibles ici : ICI

Merci d'y penser dans tes prochains messages.
Afficher la suite 

18 réponses

Répondre au sujet
yg_be 5307 Messages postés lundi 9 juin 2008Date d'inscriptionContributeurStatut 25 avril 2018 Dernière intervention - 5 déc. 2017 à 11:14
0
Utile
17
bonjour, quel message reçois-tu?
je suggère de supprimer les activate et select qui te restent.
et, surtout, de toujours indiquer la feuille sur laquelle tu travailles, donc éviter des range ou column sans rien devant.
et, encore, d'éviter autant que possible d'utiliser le presse-papier.
nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 3 janv. 2018 à 18:41
elle ne fonctionne pas elle s'arrete soudainement
nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 3 janv. 2018 à 18:41
Voila le code:

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("Input")

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


yg_be 5307 Messages postés lundi 9 juin 2008Date d'inscriptionContributeurStatut 25 avril 2018 Dernière intervention > nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 3 janv. 2018 à 19:36
quelques suggestions:
remplacer les noms sh et ws par des noms plus parlants.
je suggère de supprimer les activate et select qui te restent.
et, surtout, de toujours indiquer la feuille sur laquelle tu travailles, donc éviter des range ou column sans rien devant.
et, encore, d'éviter autant que possible d'utiliser le presse-papier.
nonossov 461 Messages postés lundi 29 décembre 2014Date d'inscription 20 février 2018 Dernière intervention - 4 janv. 2018 à 11:19
Pardon Mr, est ce que vous pouvez monter ce que vous m'avez expliqué, je ne suis pas un dev et je vouderai avoir votre aide, Merci infiniment
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?
Commenter la réponse de yg_be