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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187
| Option Explicit
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
Dim Dep As Currency
Dim Fin As Currency
Dim Freq As Currency
Sub ConcatenationFeuilles()
Dim i As Long, T() As Variant
Dim LastCol As Long, LettreLastCol As String
Dim LettreColMax As String
QueryPerformanceCounter Dep
Application.ScreenUpdating = False
ShFusion.Cells.Clear
' Dernère Colonne : dépend de la version d'Excel
' 256 97-2003 16384 depuis 2007
LettreColMax = NumCol2Lettre(Application.Columns.Count)
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> ShFusion.Name Then
' Dernière Colonne contenant des données
LastCol = Worksheets(i).Range(LettreColMax & "1").End(xlToLeft).Column
LettreLastCol = NumCol2Lettre(LastCol)
Exit For
End If
Next i
' Copie En-Tête
' Juste au cas ou la feuille de synthèse se trouverait
' en 1ere position
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> ShFusion.Name Then
With Worksheets(i)
T = .Range("A1:" & LettreLastCol & "1").Value
ShFusion.Range("A1").Resize(UBound(T, 1), UBound(T, 2)) = T
End With
Exit For
End If
Next i
' Copie des données
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> ShFusion.Name Then
With Worksheets(i)
T = .Range("A2:" & LettreLastCol & .Range("A" & Rows.Count).End(xlUp).Row).Value
ShFusion.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(UBound(T, 1), UBound(T, 2)) = T
End With
End If
Next i
Erase T
With ShFusion
.Activate
With .Cells
.WrapText = False
.MergeCells = False
End With
.Range("A1").Select
End With
Application.ScreenUpdating = True
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
Application.StatusBar = "Terminé : " & Format((Fin - Dep) / Freq, "0.00000 s")
End Sub
Private Function EstVide(Ws As Worksheet) As Boolean
If Application.WorksheetFunction.CountA(Ws.Cells) = 0 Then
EstVide = True
Else
EstVide = False
End If
End Function
Sub Nettoyage()
Dim Ws As Worksheet
Dim c As Range
Dim iNb As Long, i As Long
' Nettoyage Chr(10)
iNb = ThisWorkbook.Worksheets.Count
i = 0
QueryPerformanceCounter Dep
Application.ScreenUpdating = False
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> ShFusion.Name Then
i = i + 1
For Each c In Ws.UsedRange
c = Replace(c, Chr(10), "")
Next c
End If
Application.StatusBar = i & " / " & iNb
Next Ws
Application.ScreenUpdating = True
QueryPerformanceCounter Fin
QueryPerformanceFrequency Freq
Application.StatusBar = "Terminé : " & Format((Fin - Dep) / Freq, "0.00000 s")
End Sub
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
i = iNumCol
sStr = ""
Do While i > 0
sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
i = (i - 1) \ 26
Loop
NumCol2Lettre = sStr
End Function
Sub PosBoutons()
Dim T As Range
With ShFusion
.Activate
.Rows(1).RowHeight = 40
Set T = .Cells(1, 2)
With .Buttons("BtnNettoyage")
.Left = T.Left + 3
.Top = T.Top + 16
.Width = 100
.Height = Rows(1).RowHeight - 20
End With
With .Buttons("BtnFusion")
.Left = ShFusion.Buttons("BtnNettoyage").Left + ShFusion.Buttons("BtnNettoyage").Width + 3
.Top = ShFusion.Buttons("BtnNettoyage").Top
.Width = ShFusion.Buttons("BtnNettoyage").Width
.Height = ShFusion.Buttons("BtnNettoyage").Height
End With
With .Buttons("BtnSave")
.Left = ShFusion.Buttons("BtnFusion").Left + ShFusion.Buttons("BtnFusion").Width + 3
.Top = ShFusion.Buttons("BtnNettoyage").Top
.Width = ShFusion.Buttons("BtnNettoyage").Width
.Height = ShFusion.Buttons("BtnNettoyage").Height
End With
End With
End Sub
Sub SaveFusion()
Dim Wkb As Workbook
Dim sDateSauvegarde As String
Dim sCheminDossierSauvegarde As String
Dim sNomFichier As String
Dim LettreColMax As String
If EstVide(ShFusion) = True Then Exit Sub
sCheminDossierSauvegarde = ThisWorkbook.Path
LettreColMax = NumCol2Lettre(Application.Columns.Count)
Application.ScreenUpdating = False
sDateSauvegarde = Format(Now, "yyyymmdd")
sNomFichier = ShFusion.Name & "_" & sDateSauvegarde & ".xls"
' Si Excel >= 2007
'sNomFichier = ShFusion.Name & "_" & sDateSauvegarde & ".xlsx"
Set Wkb = Workbooks.Add
ShFusion.UsedRange.Copy Wkb.Worksheets(1).Range("A1")
Wkb.Worksheets(1).Columns("A:" & LettreColMax).Columns.AutoFit
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=sCheminDossierSauvegarde & "\" & sNomFichier, FileFormat:=xlNormal
' Si Excel >= 2007
'ActiveWorkbook.SaveAs Filename:=sCheminDossierSauvegarde & "\" & sNomFichier, _
FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWindow.Close
With ShFusion
.Activate
.Range("A1").Select
End With
Application.ScreenUpdating = True
Set Wkb = Nothing
End Sub |
Partager