'/// Variable portée Module ///
Dim T()
'//////////////////////////////
Sub aa()
Dim S As Worksheet
Dim R As Range
Dim var1
Dim var2
Dim Ret
Dim i&
Dim j&
Dim cpt&
'---
ReDim T(1 To 4, 1 To 1)
'--- Les feuilles index 1 et index 2 vont être traitées ---
Ret = MsgBox("Les 2 feuilles qui vont être traitées" & vbCrLf & Sheets(1).Name & " " & Sheets(2).Name, vbOKCancel)
If Ret = vbCancel Then Exit Sub
'--- Récupération des données de chaque feuille dans un Variant ---
Set S = Sheets(1)
Set R = S.Range(S.Cells(1, 1), S.Cells(1, S.UsedRange.Columns.Count))
var1 = R
Set S = Sheets(2)
Set R = S.Range(S.Cells(1, 1), S.Cells(1, S.UsedRange.Columns.Count))
var2 = R
'--- Balayage 1 : En-têtes communs aux 2 feuilles ---
For i& = 1 To UBound(var1, 2)
For j& = 1 To UBound(var2, 2)
If var1(1, i&) = var2(1, j&) Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 4, 1 To cpt&)
T(1, cpt&) = var1(1, i&) ' L'en-tête
T(2, cpt&) = i& ' N° actuel de colonne de la feuille 1
T(3, cpt&) = j& ' N° actuel de colonne de la feuille 2
T(4, cpt&) = cpt& ' Attribue un nouveau N° de colonne
var1(1, i&) = "" ' On efface pour balayages ultérieurs
var2(1, j&) = "" ' On efface pour balayages ultérieurs
Exit For
End If
Next j&
Next i&
'--- Balayage 2 : En-têtes particuliers de la feuille 1 ---
For i& = 1 To UBound(var1, 2)
If var1(1, i&) <> "" Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 4, 1 To cpt&)
T(1, cpt&) = var1(1, i&) ' L'en-tête
T(2, cpt&) = i& ' N° actuel de colonne de la feuille 1
T(4, cpt&) = cpt& ' Attribue un nouveau N° de colonne
End If
Next i&
'--- Balayage 3 : En-têtes particuliers de la feuille 2 ---
For i& = 1 To UBound(var2, 2)
If var2(1, i&) <> "" Then
cpt& = cpt& + 1
ReDim Preserve T(1 To 4, 1 To cpt&)
T(1, cpt&) = var2(1, i&) ' L'en-tête
T(3, cpt&) = i& ' N° actuel de colonne de la feuille 2
T(4, cpt&) = cpt& ' Attribue un nouveau N° de colonne
End If
Next i&
'--- Affichage d'un rapport (Log) ---
Set S = Sheets.Add(after:=Sheets(Sheets.Count))
Range(S.Cells(2, 1), S.Cells(cpt& + 1, 4)) = Application.WorksheetFunction.Transpose(T)
Set R = Range(S.Cells(1, 1), S.Cells(1, 4))
R = Array("TITRE", "Ancien N° colonne Feuille1", "Ancien N° colonne Feuille2", "Nouveau N° de colonne")
R.Font.Bold = True
R.HorizontalAlignment = xlCenter
S.Columns.AutoFit
'--- Réorganisation des colonnes ---
Call ReorganisationColonnes(Sheets(1), 2) 'La feuille 1
Call ReorganisationColonnes(Sheets(2), 3) 'La feuille 2
End Sub
Sub ReorganisationColonnes(S As Worksheet, Rang As Long)
'########################################################
'### Evite d'écraser les colonnes existantes, déplace ###
'### à destination du nouveau N° de colonne + 1000 ###
Const INCREMENT_DEPLACEMENT As Long = 1000
'########################################################
Dim i&
Dim B$
'---
Application.ScreenUpdating = False
'--- Déplcement des colonnes ---
For i& = 1 To UBound(T, 2)
If T(Rang, i&) <> "" Then
S.Columns(T(Rang, i&)).Cut Destination:=S.Columns(T(4, i&) + INCREMENT_DEPLACEMENT)
End If
Next i&
'--- Supprime les 1000 prèmières colonnes vides ---
B$ = Columns(INCREMENT_DEPLACEMENT).Address(False, False)
B$ = "A:" & Mid(B$, 1, InStr(1, B$, ":") - 1)
S.Columns(B$).Delete Shift:=xlToLeft
'---
Application.ScreenUpdating = True
End Sub