Macro de "mise en forme"

Marsh Posté le 18-06-2007 à 16:06:08

Bonjour!

J'ai une macro qui me fait pleins de jolie chose (import .csv, supprime 2 caractaires, compare 2 colones et mais OK ou NOK selon s'elles sont différentes)

Voici la macro:

Code :

Option Explicit
Sub Csv()
Dim Fichier As Variant
ChDir ThisWorkbook.Path
Fichier = Application.GetOpenFilename("Fichier CSV (*.csv), *.csv" )
If Fichier <> False Then
LireVerifier Fichier
End If
End Sub
Function LireVerifier(ByVal NomFichier As String)
Dim Chaine As String
Dim Ar() As String
Dim i As Long
Dim iRow As Long, iCol As Long
Dim NumFichier As Integer
Dim Separateur As String * 1
Separateur = ";"
Cells.Clear
Application.ScreenUpdating = False
NumFichier = FreeFile
iRow = 10
Open NomFichier For Input As #NumFichier
Do While Not EOF(NumFichier)
iCol = 1
Line Input #NumFichier, Chaine
Ar = Split(Chaine, Separateur)
For i = LBound(Ar) To UBound(Ar)
Ar(i) = Replace(Ar(i), "M-", "" )
Cells(iRow, iCol) = Ar(i)
iCol = iCol + 1
Next
Select Case Cells(iRow, 1)
Case Is = Cells(iRow, 2): Cells(iRow, 3) = "OK"
Case Else: Cells(iRow, 3) = "NOK"
End Select
iRow = iRow + 1
Loop
Close #NumFichier
Application.ScreenUpdating = True
End Function

Maintenant j'ai besoin de mettre en vert et gras le OK et rouge et gras le NOK, j'ai bien trouvé des truk a peu prés bon mais j'ai pas reussi a les adapter.
Et j'aimerais que la liste s'arrete au bout de 30 lignes traité puis reprénne sur une seconde feuille a cause d'une mise en page autour de mes données traité.
Pour la mise en page je pense y arrivé tout seul :whistle: .

Merci a ceux qui pourront m'aider!

Reply

Marsh Posté le 18-06-2007 à 16:06:08

Reply

Marsh Posté le 18-06-2007 à 16:12:45

Case Is = Cells(iRow, 2): Cells(iRow, 3).value = "OK"
Cells(iRow, 3).Interior.ColorIndex = 4
Cells(iRow, 3).Font.Bold = True

Case Else: Cells(iRow, 3) = "NOK"
Cells(iRow, 3).Interior.ColorIndex = 3
Cells(iRow, 3).Font.Bold = True
end select

Reply

Marsh Posté le 18-06-2007 à 16:20:31

Super quelle rapidité! Par contre c'est possible de colorer la police au lieu de la case?

EDIT: Biensur en mettant Font a la place de Interior...

Message édité par barca-powa le 18-06-2007 à 16:21:18

Reply

Marsh Posté le 19-06-2007 à 08:49:09

Sinon pour que la liste s'arrete au bout de 30 lignes traiter (soit la 40e environ) et reprenne sur une seconde feuille A4 et ainsi de suite une idée?

Reply

Marsh Posté le 19-06-2007 à 10:21:03

Je constate que ton traitement semble s'appliquer à la feuille de calcul active.
D'autre part, dans ta boucle « Do While » tu as une variable iRow qui compte les lignes.
Il suffit de créer une nouvelle feuille quand iRow atteint le seuil adéquat (vu qu'elle commence à 10, faut tester autour de 40) et rendre cette feuille active.
La boucle se poursuivra sur la nouvelle feuille.
En gros.

Reply

Marsh Posté le 25-06-2007 à 08:53:36

Ok je vois ce que tu veux dire.
Pour l'instant je suis sur la validité du document si tout est OK ou NOK.
En gros je souhaite faire ca:

Code :

If « entre C10 et C40 tout est OK » then
« mettre un fond vert de E23 à F28 »
else
« mettre un fond rouge de E23 à F28 »
endif

D'aprés ce que j'ai trouvé, la forme est bonne mais je vois pas quoi mettre dans les conditions .
Une idée?

Reply

Marsh Posté le 27-06-2007 à 11:33:27

Bon j'ai décidé de faire des enregistrements de macro avec des mise en forme conditionnel.
Mais je but sur la mise en page.

Donc j'ouvre un fichier.csv qui contient un nombre indeterminé de ligne de donnée. J'ai besoin que sur une feuille format A4 il y est 31 lignes (de 10 à 40) pour mettre l'entête de l'entreprise et des informations autour.
Donc j'aimerais un code qui sorte 31 lignes sur chaque format A4 et qu'il repete le reste de mon code.
En gros un code qui duplique ma mise en page et qui prend 31ligne par 31.

Merci de votre aide!

Reply

Marsh Posté le 27-06-2007 à 11:33:46

bjr,
vous qui maitrisez excel allez peut etre pouvoir m'aider :
quel est la routine pour définir une boucle avec un pas sous excel ?
for i = 1 to 10 + pas ?
dsl pour le hs.

Message cité 1 fois
Message édité par chacal gp le 27-06-2007 à 11:34:14

Reply

Marsh Posté le 27-06-2007 à 11:39:54

Qui moi? Non je métrise pas.
Mais par contre je vais chercher dans ce sens cette formule m'a l'air pas mal!

Reply

Marsh Posté le 27-06-2007 à 18:27:51

Voila pour le tronçonnage du fichier,à toi pour le reste

Private Sub LireVerifier(ByVal NomFichier As String)
Dim Chaine As String
Dim Ar() As String
Dim i As Long
Dim iRow As Long, iCol As Long
Dim NumFichier As Integer
Dim Separateur As String * 1
Const Pas As Integer = 9

Separateur = ";"
Cells.Clear
Application.ScreenUpdating = False
NumFichier = FreeFile

iRow = Pas

Open NomFichier For Input As #NumFichier
Do While Not EOF(NumFichier)
iCol = 1
iRow = iRow + 1
Line Input #NumFichier, Chaine
Ar = Split(Chaine, Separateur)
For i = LBound(Ar) To UBound(Ar)
Ar(i) = Replace(Ar(i), "M-", "" )
Cells(iRow, iCol) = Ar(i)
iCol = iCol + 1
Next

Select Case Cells(iRow, 1)
Case Is = Cells(iRow, 2):
Cells(iRow, 3) = "OK"
Cells(iRow, 3).Font.Bold = True
Cells(iRow, 3).Font.ColorIndex = 4
Case Else:
Cells(iRow, 3) = "NOK"
Cells(iRow, 3).Font.Bold = True
Cells(iRow, 3).Font.ColorIndex = 3
End Select

If iRow Mod 40 = 0 Then iRow = iRow + Pas
Loop
Close #NumFichier

Application.ScreenUpdating = True
End Sub

Reply

Marsh Posté le 27-06-2007 à 18:27:51

Reply

Marsh Posté le 27-06-2007 à 19:15:30

MERCI. Vraiment merci beaucoup! Je test ca demain mais j'ai compris le principe avec le pas.

Reply

Marsh Posté le 28-06-2007 à 08:25:53

chacal gp a écrit :

bjr,
vous qui maitrisez excel allez peut etre pouvoir m'aider :
quel est la routine pour définir une boucle avec un pas sous excel ?
for i = 1 to 10 + pas ?
dsl pour le hs.

Tu peux faire
For i=1 to 10
blablabla...
i=i+1
next

Tu pars de 1(suivant ou est ton blablabla) et puis de 2 en 2. (1-3-5-7-9) à adapter en fonction de ton pas

Tu peux aussi utiliser : Do while
i=1
Do while i<10
blablabla...
i=i+2
loop

Reply

Marsh Posté le 28-06-2007 à 11:34:00

Bon pour le "tronçonnage" du fichier ca fonctionne.
J'ai essayé de bidouillet pour que le coupage ce face de tel maniére que le découpage ce facepour que les ligne traité ce trouve toujours au milieu d'une page A4 mais sans y parvenir...

Je cherche a obtenir 10 ligne vide avant et 7 aprés sur le modéle A4.
J'ai pensé mettre un +7 sur une ligne

If iRow Mod 45 = 0 Then iRow = iRow + pas + 7

J'ai obtenu ce que je veux mais maintenant il faut que les données traité de s'arrete pas a 45*2 (à la ligne 90) et mette les 17 ligne vide car 90+17=107 et comme la 3e feuille commence a 105 là je n'est plus mes 10 ligne de vide et sur la 2e feuille je n'est plus mes 7 ligne de vide a la fin mais j'en est 14...

Je pense que vous voyez ce que je veux dire. J'ai essayé de triché mais au bout d'un moment le decalage devient trop grand et empiete sur mon en-tête...

Un as du VBA pour m'aider? :bounce:

Reply

Marsh Posté le 28-06-2007 à 14:16:44

A adapter
Sur la base de mon code de départ + macro recorder + adaptation manuelle du code ( imprimante par défaut : Adobe PDF )

Sub Mep()
Dim LastRow As Long
Dim i As Long
Dim NbPages As Long
Dim iRowDep As Long, iRowFin As Long
Dim Debut As Variant

LastRow = Range("A65536" ).End(xlUp).Row
NbPages = Application.WorksheetFunction.RoundUp(LastRow / 40, 0)
Debut = Time
iRowDep = 1
iRowFin = 40
Application.ScreenUpdating = False
For i = 1 To NbPages
Range("A" & iRowDep & ":C" & iRowFin).Select
ActiveSheet.PageSetup.PrintArea = "$A$" & iRowDep & ":$C$" & iRowFin
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = 0
.FooterMargin = 0
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 1200
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Application.StatusBar = i & " / " & NbPages
iRowDep = iRowFin + 1
iRowFin = iRowFin + 40
Next i
Application.ScreenUpdating = True
Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
End Sub

Message édité par kiki29 le 28-06-2007 à 14:29:29

Reply

Marsh Posté le 03-07-2007 à 09:27:58

Bonjour!
Désolé de ne pas avoir répondu plutôt.
Déjà merci pour ce code qui fonctionne parfaitement, juste:

'.PrintQuality = 1200
'.PrintErrors = xlPrintErrorsDisplayed

Que j'ai du retirer.

J'ai réussi pour la présentation. Le seule truck qui me reste à faire c'est un carré de couleur sur chaque page qui sert a facilité le contrôle. Si les 40 valeurs sont OK le carré doit être vert ou si il y a un NOK il doit être rouge.
Ca je sais le faire mais pour qu'il le répete toute les 40 ligne je pige pas. J'ai essayé avec des enregistrement de macro en faisant un NB.SI sur les 40 lignes puis une mise en forme conditionel en fonction du résultat du NB.SI mais déjà c'est trés lourd et en plus avec ce systeme je ne peut pas contrôler en fonction du nombre reel qu'il y aura de ligne.
Quelqu'un peut m'aider? Je sais ca fait beaucoup d'aide mais j'y connais presque rien. :whistle:

Reply

Marsh Posté le 03-07-2007 à 11:43:26

Tu as déjà une bonne partie de la réponse dans la routine de Mise en Page, il suffit d'en reprendre la boucle principale et d'y incorporer qqch comme

.........
For j = iRowDep To iRowFin
If Cells(j, 3) = "OK" Then Cpt = Cpt + 1
Next j
If Cpt >= NbOk Then
Range("A" & iRowDep & ":C" & iRowFin).Interior.ColorIndex = 35
Else
Range("A" & iRowDep & ":C" & iRowFin).Interior.ColorIndex = 40
End If
Cpt = 0
...........

Reply

Marsh Posté le 03-07-2007 à 15:56:18

Bon alors big merci a kiki!!

Par contre avec ce code il m'imprime qu'une seule page :heink:

Sub Mep()
Dim LastRow As Long
Dim i As Long
Dim NbPages As Long
Dim iRowDep As Long, iRowFin As Long
Dim Debut As Variant

LastRow = Range("A65536" ).End(xlUp).Row
NbPages = Application.WorksheetFunction.RoundUp(LastRow / 40, 0)
Debut = Time
iRowDep = 1
iRowFin = 40
Application.ScreenUpdating = False
For i = 1 To NbPages
Range("A" & iRowDep & ":G" & iRowFin).Select
ActiveSheet.PageSetup.PrintArea = "$A$" & iRowDep & ":$G$" & iRowFin
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = _
""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = 0
.FooterMargin = 0
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
'.PrintQuality = 1200
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
'.PrintErrors = xlPrintErrorsDisplayed
End With

Next i
For j = iRowDep To iRowFin
If Cells(j, 3) = "OK" Then Cpt = Cpt + 1
Next j
If Cpt = 40 Then
Range("E" & iRowDep + 17 & ":E" & iRowFin - 17).Interior.ColorIndex = 10
Else
Range("E" & iRowDep + 17 & ":E" & iRowFin - 17).Interior.ColorIndex = 3
End If
Cpt = 0
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Application.StatusBar = i & " / " & NbPages
iRowDep = iRowFin + 1
iRowFin = iRowFin + 40
Application.ScreenUpdating = True
Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00" )
End Sub

J'ai pas tout compris...

Reply

Marsh Posté le 03-07-2007 à 16:25:39

N'importe quoi, tu ne comprends rien , je t'ai dit de reprendre la boucle principale pas l'ensemble du code

Reply

Marsh Posté le 03-07-2007 à 16:31:21

Sub DecompteOK()
Dim LastRow As Long
Dim i As Long, j As Long
Dim NbPages As Long
Dim iRowDep As Long, iRowFin As Long
Dim Cpt As Long
Const NbOk As Integer = 31

LastRow = Range("A65536" ).End(xlUp).Row
NbPages = Application.WorksheetFunction.RoundUp(LastRow / 40, 0)
iRowDep = 1
iRowFin = 40
Cpt = 0
Application.ScreenUpdating = False
For i = 1 To NbPages
For j = iRowDep To iRowFin
If Cells(j, 3) = "OK" Then Cpt = Cpt + 1
Next j
If Cpt >= NbOk Then
Range("A" & iRowDep & ":C" & iRowFin).Interior.ColorIndex = 35
Else
Range("A" & iRowDep & ":C" & iRowFin).Interior.ColorIndex = 40
End If
Cpt = 0
iRowDep = iRowFin + 1
iRowFin = iRowFin + 40
Next i
Application.ScreenUpdating = True
Application.StatusBar = "Terminé"
End Sub

Reply

Marsh Posté le 03-07-2007 à 16:41:01

Merci de ta patience.

Reply

Macro de "mise en forme"

Sujets relatifs:

Leave a Replay