Sub CREER_GRAPHIQUE()
' à partir d'un fichier à 5 colonnes
' ( 1 = identifiant serie,
' 2 = titre graphique,
' 3 = titre des abcisses,
' 4 = date,
' 5 = valeur)
' contenant n séries triées
' découpe les données par série, et pour chaque série :
' - copie les valeurs sur une nouvelle feuille
' - crée un graphique à partir de ces valeurs (avec le titre)
' - enregistre ce graphique au format pdf dans un répertoire donné
' avec comme nom l'identifiant de la série
Dim WS As Worksheet
Dim i, k, l As Integer
Dim IdSerie As String
' k enregistre la ligne de début d'une série
k = 3
' WS est le feuille d'origine qui contient ttes les données
Set WS = ActiveWorkbook.ActiveSheet
' IdSerie contient la série en cours - permet de tester si on change de série
'
IdSerie = WS.Cells(2, 1)
' lecture de l'ensemble des données
' - préciser le nb de lignes et mettre FIN dans la dernière ligne du fichier
' dans la 1ère col
'
For i = 3 To 17132
'
' sélection de la ligne
WS.Rows(i).Select
'
' test du changement de série : dans ce cas il y a action
If IdSerie <> WS.Cells(i, 1) Or WS.Cells(i, 1) = "FIN" Then
'
' sélection des valeurs la série (col D et E)
'
Range("D" & k & ":E" & (i - 1)).Select
WS.Range("D" & k & ":E" & (i - 1)).Copy
' ajout d'une feuille - nommée par l'id (col A)
'
Sheets.Add
ActiveSheet.Name = IdSerie
' copie de la sélection
ActiveSheet.Paste
' copie en ligne 1 des infos de titres
WS.Range("A" & k & ":C" & k).Copy
Selection.EntireRow.Insert
'
' création et export du graphique en pdf
'
Charts.Add
With ActiveChart
.ChartType = xlLineMarkers
.SetSourceData Source:=WS.Range("D" & k & ":E" & (i - 1)), PlotBy _
:=xlColumns
.Name = IdSerie & "_graph"
.HasDataTable = False
.HasTitle = True
.ChartTitle.Characters.text = WS.Cells((i - 1), 2)
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.text = "date"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.text = WS.Cells((i - 1), 3)
.Export Filename:="Q:\GRAPH\" & IdSerie & ".jpg", FilterName:="JPEG"
End With
' mise à jour des variables pour la série suivante
'
k = i
IdSerie = WS.Cells(i, 1)
' repositionnement sur la feuille initiale
'
WS.Activate
End If
Next
End Sub
'
'
'
VISUALBASIC
Mardi 23 novembre 2010
2
23
/11
/Nov
/2010
10:13
Jeudi 4 février 2010
4
04
/02
/Fév
/2010
17:42
ce script par d'un format précis des tables dans le doc :
-chaque table est dans un tableau
le tableau est comme suit : - ligne 1 : nom de la table en col 2, comment en col 3
ligne suivantes : nom col en col 2, comment en col 3, 'O' en col 4 si obligatoire, 'PK' en col 5 si primary key,
' FK : ' suivi de la reference si FK en col 6 ou 'CK' suivi de la condition si Check, Type col en col 7 (V=varchar2,N=number, DATE pour DATE)
Dim Gligne As Integer
Dim Gdoc As Integer
Sub SInsert(txt As String)
' insert le texte en fin de fichier
With Application.Documents(Gdoc).Paragraphs(Gligne).Range
.Text = Replace(txt, Chr(13), "")
.InsertParagraphAfter
End With
Gligne = Gligne + 1
End Sub
Sub Commentaire(txt As String)
' insert un commentaire encadré de lignes de tirets
SInsert (String(80, "-"))
SInsert ("-- " & txt)
SInsert (String(80, "-"))
SInsert ("")
End Sub
Sub GenerationScriptSql()
'
' Génération du script de création de table
' Macro créée le 03/02/2010 par sgouzien
'
Dim objDoc As Document, Phrase As Range
Dim vTab As String
Dim vCons As String
Set objDoc = ActiveDocument
'création de 2 documents (un pour les tables EDIOS, l'autre pour les tables SDN)
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
' preparation de l'entete du premier fichier
Gdoc = 1
Gligne = 1
Commentaire ("Création des tables pour EDIOS - Généré le " & Date)
' boucle de génération des DROP
For j = 1 To objDoc.Tables.Count
Set objT = objDoc.Tables(j)
If Mid(objT.Cell(1, 1), 1, 1) = "T" Then
vTab = objT.Cell(1, 2)
SInsert ("DROP TABLE " & vTab & " CASCADE CONSTRAINT;")
End If
Next
' boucle sur les tableaux du document
For j = 1 To objDoc.Tables.Count
Set objT = objDoc.Tables(j)
'les tableaux concernant des tables sont identifiés par un "T" en (1,1)
If Mid(objT.Cell(1, 1), 1, 1) = "T" Then
vTab = objT.Cell(1, 2)
vCons = "ALTER TABLE " & vTab & " ADD ( CONSTRAINT "
' fermeture du premier fichier et preparation de l'entete du second fichier
If Mid(vTab, 1, 3) = "SDN" And Gdoc = 1 Then
Documents(1).SaveAs FileName:="CreEdios.sql", FileFormat:=wdFormatText
Gdoc = 2
Gligne = 1
Commentaire ("Création des tables Seadatanet pour EDIOS - Généré le " & Date)
End If
' creation des tables
Commentaire ("Table " & vTab & " - " & objT.Cell(1, 3))
SInsert ("CREATE TABLE " & vTab & " (")
For i = 2 To objT.Rows.Count
Select Case Mid(objT.Cell(i, 7), 1, 1)
Case "V"
taille = "VARCHAR2" & Mid(objT.Cell(i, 7), 2)
Case "N"
taille = "NUMBER" & Mid(objT.Cell(i, 7), 2)
Case "D"
taille = "DATE"
End Select
If i = objT.Rows.Count Then
SInsert (objT.Cell(i, 2) & " " & taille)
Else
SInsert (objT.Cell(i, 2) & " " & taille & ",")
End If
Next
SInsert (");")
SInsert ("")
' creation des Index et contraintes
Commentaire ("Index et contraintes sur " & vTab)
For i = 2 To objT.Rows.Count
' creation des PRIMARY KEY
If Mid(objT.Cell(i, 5), 1, 2) = "PK" Then
If i = 2 Then
SInsert (vCons)
SInsert ("PK_" & vTab & " PRIMARY KEY (" & objT.Cell(i, 2))
If Mid(objT.Cell(i + 1, 5), 1, 2) = "PK" Then
SInsert (",")
Else
SInsert ("));")
End If
Else
SInsert (objT.Cell(i, 2))
If i = objT.Rows.Count Then
SInsert ("));")
ElseIf Mid(objT.Cell(i + 1, 5), 1, 2) = "PK" Then
SInsert (",")
Else
SInsert ("));")
End If
End If
End If
Next
SInsert ("")
' creation des CHECK CONSTRAINTES (NULL)
For i = 2 To objT.Rows.Count
If Mid(objT.Cell(i, 4), 1, 1) = "O" Then
SInsert (vCons)
SInsert ("CK_" & objT.Cell(i, 2) & "_O CHECK (")
SInsert (objT.Cell(i, 2)) & " IS NOT NULL ));"
SInsert ("")
End If
' creation des CHECK CONSTRAINTES (AUTRE)
If Mid(objT.Cell(i, 6), 1, 2) = "CK" Then
SInsert (vCons)
SInsert ("CK_" & objT.Cell(i, 2) & " CHECK (")
SInsert (objT.Cell(i, 2) & " " & Mid(objT.Cell(i, 6), 5) & "));")
SInsert ("")
End If
Next
' creation des FOREIGN KEY
For i = 2 To objT.Rows.Count
If Mid(objT.Cell(i, 6), 1, 2) = "FK" Then
SInsert (vCons)
SInsert ("FK_" & objT.Cell(i, 2) & " FOREIGN KEY (" & objT.Cell(i, 2)) & ")"
SInsert ("REFERENCES " & Mid(objT.Cell(i, 6), 5) & ");")
SInsert ("")
End If
Next
' creation des Commentaires
Commentaire ("Commentaires sur " & vTab)
SInsert ("COMMENT ON TABLE " & vTab & " IS '" & objT.Cell(1, 3) & "';")
For i = 2 To objT.Rows.Count
SInsert ("COMMENT ON COLUMN " & vTab & "." & objT.Cell(i, 2) & _
" IS '" & objT.Cell(i, 3) & "';")
Next
End If
Next
'Set def off
Rem (Set def off permet de faire passer les " & " en caracteres normaux)
Documents(2).SaveAs FileName:="CreEdiosSdn.sql", FileFormat:=wdFormatText
MsgBox ("fini")
End Sub
-chaque table est dans un tableau
le tableau est comme suit : - ligne 1 : nom de la table en col 2, comment en col 3
ligne suivantes : nom col en col 2, comment en col 3, 'O' en col 4 si obligatoire, 'PK' en col 5 si primary key,
' FK : ' suivi de la reference si FK en col 6 ou 'CK' suivi de la condition si Check, Type col en col 7 (V=varchar2,N=number, DATE pour DATE)
|
T |
OBS_PLA |
PLATEFORME LIEE A L’‘OBSERVATOIRE |
O |
PK |
O/PK/FK |
Taille |
|
|
OPL_COBS |
Code observatoire référencé la table OBS |
|
PK |
FK : OBS ( OBS_COBS) |
N(9) |
|
|
OPL_NOM |
Nom plateforme |
|
PK |
CK : in ('A','B') |
V(50) |
Dim Gligne As Integer
Dim Gdoc As Integer
Sub SInsert(txt As String)
' insert le texte en fin de fichier
With Application.Documents(Gdoc).Paragraphs(Gligne).Range
.Text = Replace(txt, Chr(13), "")
.InsertParagraphAfter
End With
Gligne = Gligne + 1
End Sub
Sub Commentaire(txt As String)
' insert un commentaire encadré de lignes de tirets
SInsert (String(80, "-"))
SInsert ("-- " & txt)
SInsert (String(80, "-"))
SInsert ("")
End Sub
Sub GenerationScriptSql()
'
' Génération du script de création de table
' Macro créée le 03/02/2010 par sgouzien
'
Dim objDoc As Document, Phrase As Range
Dim vTab As String
Dim vCons As String
Set objDoc = ActiveDocument
'création de 2 documents (un pour les tables EDIOS, l'autre pour les tables SDN)
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
' preparation de l'entete du premier fichier
Gdoc = 1
Gligne = 1
Commentaire ("Création des tables pour EDIOS - Généré le " & Date)
' boucle de génération des DROP
For j = 1 To objDoc.Tables.Count
Set objT = objDoc.Tables(j)
If Mid(objT.Cell(1, 1), 1, 1) = "T" Then
vTab = objT.Cell(1, 2)
SInsert ("DROP TABLE " & vTab & " CASCADE CONSTRAINT;")
End If
Next
' boucle sur les tableaux du document
For j = 1 To objDoc.Tables.Count
Set objT = objDoc.Tables(j)
'les tableaux concernant des tables sont identifiés par un "T" en (1,1)
If Mid(objT.Cell(1, 1), 1, 1) = "T" Then
vTab = objT.Cell(1, 2)
vCons = "ALTER TABLE " & vTab & " ADD ( CONSTRAINT "
' fermeture du premier fichier et preparation de l'entete du second fichier
If Mid(vTab, 1, 3) = "SDN" And Gdoc = 1 Then
Documents(1).SaveAs FileName:="CreEdios.sql", FileFormat:=wdFormatText
Gdoc = 2
Gligne = 1
Commentaire ("Création des tables Seadatanet pour EDIOS - Généré le " & Date)
End If
' creation des tables
Commentaire ("Table " & vTab & " - " & objT.Cell(1, 3))
SInsert ("CREATE TABLE " & vTab & " (")
For i = 2 To objT.Rows.Count
Select Case Mid(objT.Cell(i, 7), 1, 1)
Case "V"
taille = "VARCHAR2" & Mid(objT.Cell(i, 7), 2)
Case "N"
taille = "NUMBER" & Mid(objT.Cell(i, 7), 2)
Case "D"
taille = "DATE"
End Select
If i = objT.Rows.Count Then
SInsert (objT.Cell(i, 2) & " " & taille)
Else
SInsert (objT.Cell(i, 2) & " " & taille & ",")
End If
Next
SInsert (");")
SInsert ("")
' creation des Index et contraintes
Commentaire ("Index et contraintes sur " & vTab)
For i = 2 To objT.Rows.Count
' creation des PRIMARY KEY
If Mid(objT.Cell(i, 5), 1, 2) = "PK" Then
If i = 2 Then
SInsert (vCons)
SInsert ("PK_" & vTab & " PRIMARY KEY (" & objT.Cell(i, 2))
If Mid(objT.Cell(i + 1, 5), 1, 2) = "PK" Then
SInsert (",")
Else
SInsert ("));")
End If
Else
SInsert (objT.Cell(i, 2))
If i = objT.Rows.Count Then
SInsert ("));")
ElseIf Mid(objT.Cell(i + 1, 5), 1, 2) = "PK" Then
SInsert (",")
Else
SInsert ("));")
End If
End If
End If
Next
SInsert ("")
' creation des CHECK CONSTRAINTES (NULL)
For i = 2 To objT.Rows.Count
If Mid(objT.Cell(i, 4), 1, 1) = "O" Then
SInsert (vCons)
SInsert ("CK_" & objT.Cell(i, 2) & "_O CHECK (")
SInsert (objT.Cell(i, 2)) & " IS NOT NULL ));"
SInsert ("")
End If
' creation des CHECK CONSTRAINTES (AUTRE)
If Mid(objT.Cell(i, 6), 1, 2) = "CK" Then
SInsert (vCons)
SInsert ("CK_" & objT.Cell(i, 2) & " CHECK (")
SInsert (objT.Cell(i, 2) & " " & Mid(objT.Cell(i, 6), 5) & "));")
SInsert ("")
End If
Next
' creation des FOREIGN KEY
For i = 2 To objT.Rows.Count
If Mid(objT.Cell(i, 6), 1, 2) = "FK" Then
SInsert (vCons)
SInsert ("FK_" & objT.Cell(i, 2) & " FOREIGN KEY (" & objT.Cell(i, 2)) & ")"
SInsert ("REFERENCES " & Mid(objT.Cell(i, 6), 5) & ");")
SInsert ("")
End If
Next
' creation des Commentaires
Commentaire ("Commentaires sur " & vTab)
SInsert ("COMMENT ON TABLE " & vTab & " IS '" & objT.Cell(1, 3) & "';")
For i = 2 To objT.Rows.Count
SInsert ("COMMENT ON COLUMN " & vTab & "." & objT.Cell(i, 2) & _
" IS '" & objT.Cell(i, 3) & "';")
Next
End If
Next
'Set def off
Rem (Set def off permet de faire passer les " & " en caracteres normaux)
Documents(2).SaveAs FileName:="CreEdiosSdn.sql", FileFormat:=wdFormatText
MsgBox ("fini")
End Sub
Vendredi 29 janvier 2010
5
29
/01
/Jan
/2010
16:18
Sub LONGUEUR_MAX_UNE_COLONNE()
'
'
'
Dim WS As Worksheet
Dim i As Integer
Dim com As String
Dim col As String
' parcours tous les cellules d'une colonne et retourne la taille maximale trouvée, :
col = InputBox("Entrez le nom de la colonne (A,B,...)", "Colonne", "A")
i = 0
For n = 1 To Rows.Count
If i < Len(Cells(n, col).Value) Then i = Len(Cells(n, col).Value)
Next n
MsgBox ("longueur maxi de " & col & " : " & i)
End Sub
Sub LONGUEUR_MAX_TOUTES_COLONNES()
'
'
'
Dim WS As Worksheet
Dim i As Integer
Dim com As String
Dim col As String
' parcours toutes les cellules de toutes les colonnes
' et retourne la taille maximale trouvée
' on ne tient pas compte de la première ligne qui contient les titres
com = " longueur maxi de "
For m = 1 To ActiveSheet.UsedRange.Columns.Count
i = 0
For n = 2 To ActiveSheet.UsedRange.Rows.Count
If i < Len(Cells(n, m).Value) Then i = Len(Cells(n, m).Value)
Next n
com = com & " " & Chr(64 + m) & " : " & i & " - "
Next m
MsgBox (com)
End Sub
'
'
'
Dim WS As Worksheet
Dim i As Integer
Dim com As String
Dim col As String
' parcours tous les cellules d'une colonne et retourne la taille maximale trouvée, :
col = InputBox("Entrez le nom de la colonne (A,B,...)", "Colonne", "A")
i = 0
For n = 1 To Rows.Count
If i < Len(Cells(n, col).Value) Then i = Len(Cells(n, col).Value)
Next n
MsgBox ("longueur maxi de " & col & " : " & i)
End Sub
Sub LONGUEUR_MAX_TOUTES_COLONNES()
'
'
'
Dim WS As Worksheet
Dim i As Integer
Dim com As String
Dim col As String
' parcours toutes les cellules de toutes les colonnes
' et retourne la taille maximale trouvée
' on ne tient pas compte de la première ligne qui contient les titres
com = " longueur maxi de "
For m = 1 To ActiveSheet.UsedRange.Columns.Count
i = 0
For n = 2 To ActiveSheet.UsedRange.Rows.Count
If i < Len(Cells(n, m).Value) Then i = Len(Cells(n, m).Value)
Next n
com = com & " " & Chr(64 + m) & " : " & i & " - "
Next m
MsgBox (com)
End Sub
Lundi 18 janvier 2010
1
18
/01
/Jan
/2010
10:39
Sub MacroCreOnglet()
'
' Macro enregistrée le 15/01/2010 par sgouzien
' Cette macro créé des onglets dans un fichier station.xls a partir
' de fichiers ascii se trouvant dans un répertoire /travail de newdata
' Dans notre cas les noms des fichiers sont composes ainsi dn401.ctd
' et jusqu'a dn459.ctd avec des numeros qui ne se suivent pas. Il n'y a
' que 51 fichiers dans le répertoire.
Dim i As Integer
Dim tt As String
On Error Resume Next
i = 1
j = 401
k = 1
For i = 1 To 60
Workbooks.OpenText Filename:="R:\newdata\dino4\ctd\travail\dn" & j & ".ctd", _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
'Workbooks.OpenText OuvF, xlWindows, , , , , True
'If Err <> 0 Then MsgBox Err & "Vous n'avez choisi un fichier texte valide"
'If Err = 0 Then
'Workbook.ActiveSheet.Copy
'Workbook("R:\newdata\dino4\ctd\travail\dn" & j & ".ctd").ActiveSheet.Copy
'Application.CutCopyMode = False
'tt = ActiveWorkbook.ActiveSheet.Name
'tt = Workbooks("stations.xls").Sheets(i - 7).Name
If ActiveWorkbook.ActiveSheet.Name = "dn" & j Then
ActiveWorkbook.ActiveSheet.Move Before:=Workbooks("station.xls").Sheets(k)
k = k + 1
End If
'Workbooks("R:\newdata\dino4\ctd\travail\dn" & j & ".ctd").Close
'ActiveWorkbook.Close
'End If
j = j + 1
Next
End Sub
Function OuvF()
OuvF = Application.GetOpenFilename("Fichier Texte (*.txt), *.txt")
End Function
'
' Macro enregistrée le 15/01/2010 par sgouzien
' Cette macro créé des onglets dans un fichier station.xls a partir
' de fichiers ascii se trouvant dans un répertoire /travail de newdata
' Dans notre cas les noms des fichiers sont composes ainsi dn401.ctd
' et jusqu'a dn459.ctd avec des numeros qui ne se suivent pas. Il n'y a
' que 51 fichiers dans le répertoire.
Dim i As Integer
Dim tt As String
On Error Resume Next
i = 1
j = 401
k = 1
For i = 1 To 60
Workbooks.OpenText Filename:="R:\newdata\dino4\ctd\travail\dn" & j & ".ctd", _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 1), _
TrailingMinusNumbers:=True
'Workbooks.OpenText OuvF, xlWindows, , , , , True
'If Err <> 0 Then MsgBox Err & "Vous n'avez choisi un fichier texte valide"
'If Err = 0 Then
'Workbook.ActiveSheet.Copy
'Workbook("R:\newdata\dino4\ctd\travail\dn" & j & ".ctd").ActiveSheet.Copy
'Application.CutCopyMode = False
'tt = ActiveWorkbook.ActiveSheet.Name
'tt = Workbooks("stations.xls").Sheets(i - 7).Name
If ActiveWorkbook.ActiveSheet.Name = "dn" & j Then
ActiveWorkbook.ActiveSheet.Move Before:=Workbooks("station.xls").Sheets(k)
k = k + 1
End If
'Workbooks("R:\newdata\dino4\ctd\travail\dn" & j & ".ctd").Close
'ActiveWorkbook.Close
'End If
j = j + 1
Next
End Sub
Function OuvF()
OuvF = Application.GetOpenFilename("Fichier Texte (*.txt), *.txt")
End Function
Lundi 18 janvier 2010
1
18
/01
/Jan
/2010
10:39
Sub DEBUT_FEUILLE_TOUS()
'
'
' Macro enregistrée le 30/09/2009 par sgouzien
' retaille chaque feuille de tous les fichiers ouverts
' supprime les lignes blanches en fin de fichier
'
Dim WB As Workbook
Dim WS As Worksheet
Dim i As Integer
Dim j As Integer
i = 0
' désactiver le rafraîchissement de l'écran pour accélérer le traitement
Application.ScreenUpdating = False
' parcours tous les fichiers, et dans chaque fichier :
For Each WB In Workbooks
If WB.Name <> "macro.xls" Then
' parcours tous les feuilles du fichier, et dans chaque feuille :
i = i + 1
For Each WS In WB.Worksheets
WS.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Range("A1").Select
' retaille toutes les colonnes
WS.Columns.ColumnWidth = 13
' Masque les colonnes C, H et J
WS.Range("C:C,H:H,I:I,J:J").EntireColumn.Hidden = True
' supprime les lignes blanches en fin de fichier :
' on suppose qu'il y a au max 2000 lignes et que si la première cellule est vide c'est que la ligne est vide
For i = 2000 To 1 Step -1
If IsEmpty(WS.Rows(i)) Then WS.Rows(i).Delete
Next
Next
WB.Worksheets(1).Activate
WB.Save
End If
Next
' désactiver le rafraîchissement de l'écran pour accélérer le traitement
Application.ScreenUpdating = True
MsgBox ("fin du traitement, " & i & " fichiers traités ")
End Sub
'
'
' Macro enregistrée le 30/09/2009 par sgouzien
' retaille chaque feuille de tous les fichiers ouverts
' supprime les lignes blanches en fin de fichier
'
Dim WB As Workbook
Dim WS As Worksheet
Dim i As Integer
Dim j As Integer
i = 0
' désactiver le rafraîchissement de l'écran pour accélérer le traitement
Application.ScreenUpdating = False
' parcours tous les fichiers, et dans chaque fichier :
For Each WB In Workbooks
If WB.Name <> "macro.xls" Then
' parcours tous les feuilles du fichier, et dans chaque feuille :
i = i + 1
For Each WS In WB.Worksheets
WS.Activate
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Range("A1").Select
' retaille toutes les colonnes
WS.Columns.ColumnWidth = 13
' Masque les colonnes C, H et J
WS.Range("C:C,H:H,I:I,J:J").EntireColumn.Hidden = True
' supprime les lignes blanches en fin de fichier :
' on suppose qu'il y a au max 2000 lignes et que si la première cellule est vide c'est que la ligne est vide
For i = 2000 To 1 Step -1
If IsEmpty(WS.Rows(i)) Then WS.Rows(i).Delete
Next
Next
WB.Worksheets(1).Activate
WB.Save
End If
Next
' désactiver le rafraîchissement de l'écran pour accélérer le traitement
Application.ScreenUpdating = True
MsgBox ("fin du traitement, " & i & " fichiers traités ")
End Sub
Présentation
- : Le blog de memoprog
-
- : Hi Tech
- : Blog "memo" : contient des scripts de programmes : shell (csh), awk, VisualBasic (pour Macros Excel), Oracle
- Partager ce blog
- Retour à la page d'accueil
- Contact
Créer un Blog
Recherche
Articles récents
- Créer et enregistrer en pdf des graphiques ss EXCEL
- concatenation de plusieurs lignes avec séparateur
- recompilation des vues et triggers invalides
- correction d'anomalie sur la taille de colonnes liées par des contraintes d'intégrité référentielles
- Generation d'un script (vb word) de creation de base
- printf, substr
- Donne la taille maximale des textes contenus dans 1 ou toutes les colonnes
- créé n onglets dans un fichier a partir de n fichiers ascii
- retaille chaque feuille de tous les fichiers ouverts + supprime les lignes blanches en fin de fichier
- Remonte en haut les ascenseurs horizontaux et verticaux et place le curseur sur la première cellule de la première feuille
Calendrier
| Mai 2012 | ||||||||||
| L | M | M | J | V | S | D | ||||
| 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 | |||||||
|
||||||||||