1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80
|
Function macro1()
'
' Macro1 Macro
' Macro enregistrée le 20/10/2005 par pommbe01
'
Dim appXl As Excel.Application
Set appXl = CreateObject("Excel.Application")
'Pour ne pas avoir d'avertissement si le fichier est déjà créé
appXl.DisplayAlerts = False
'Affiche (True) ou pas (False) la fenêtre Excel
appXl.Visible = False
appXl.AskToUpdateLinks = False
appXl.Workbooks.Open Filename:="C:\Documents and Settings\pommbe01\Bureau\IMP"
Dim c As Variant, compte As Integer
compte = 0
'
appXl.Range("A1:B1").Select
appXl.Selection.Font.Bold = True
appXl.Columns("A:A").EntireColumn.AutoFit
appXl.Columns("B:B").EntireColumn.AutoFit
appXl.Range("A2").CurrentRegion.Select
appXl.Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For Each c In Range("A2", appXl.Range("A2").End(xlDown).Address)
c.Select
'faire le calcul
If c.Offset(-1, 0) = c Then
compte = c.Offset(-1, 1) + c.Offset(0, 1)
c.Offset(0, 3) = compte
Else
c.Offset(0, 3) = c.Offset(0, 1)
compte = 0
End If
Next
'nettoyer les résultats superflus
For Each c In Range("A2", Range("A2").End(xlDown).Address)
If c.Offset(1, 0) = c Then
c.Offset(0, 3) = ""
End If
Next
'effacer les lignes
appXl.Range("A2").End(xlDown).Select
go:
If appXl.Selection.Address <> "$A$2" Then
If appXl.Selection.Offset(-1, 0) = appXl.Selection Then
appXl.Selection.Offset(-1, 0).EntireRow.Delete
End If
appXl.Selection.Offset(-1, 0).Select
GoTo go
End If
appXl.Range("B1").Select
appXl.Selection.Copy
appXl.Range("D1").Select
appXl.ActiveSheet.Paste
appXl.Columns("B:B").Select
appXl.Application.CutCopyMode = False
appXl.Selection.Delete Shift:=xlToLeft
appXl.Columns("C:C").Select
appXl.Selection.Cut
appXl.Columns("B:B").Select
appXl.ActiveSheet.Paste
Workbooks("IMP.XLS").Close SaveChanges:=False
Set appXl = Nothing
End Function |
Partager