Option Explicit
Option Compare Text
Sub homogeneisation()
Dim i As Integer, j As Integer, k As Integer, m As Integer, Feuille_X As String, Feuille_Y As String, Ligne_vide As Integer
Dim Ligne_du_haut As Integer, Ligne_du_bas As Integer, Nombre_de_lignes As Integer, Nombre_de_colonnes As Byte
Dim Fichier1 As String, Fichier2 As String, Sht As Worksheet
Application.ScreenUpdating = False
''pour éviter saisie nom feuil1
retour1:
Fichier1 = InputBox("Indiquez votre 1er Fichier à Homogénéiser", "Fichier1")
If Fichier1 = "" Then
MsgBox "Vous avez annulé le choix de la 1ère feuille!", vbOKOnly + vbInformation, "ANNULATION UTILISATEUR"
Else
'Sheets(1) et Sheets(2) sont les feuilles contenants les données (adapter les indexes)
If Fichier1 = Sheets(1).Name Or Fichier1 = Sheets(2).Name Then
MsgBox "Non autorisé! correspond à la source de données." & vbLf & "Saisir un autre nom de feuille.", vbCritical + vbOKOnly, "ECHEC NOM FEUILLE"
GoTo retour1
End If
End If
' Stop
''pour éviter saisie nom feuil2
retour2:
Fichier2 = InputBox("Indiquez votre 2nd Fichier à Homogénéiser", "Fichier2")
If Fichier2 = "" Then
MsgBox "Vous avez annulé le choix de la 2nd feuille!", vbOKOnly + vbInformation, "ANNULATION UTILISATEUR"
Else
'Sheets(1) et Sheets(2) sont les feuilles contenants les données (adapter les indexes)
If Fichier1 = Sheets(1).Name Or Fichier1 = Sheets(2).Name Then
MsgBox "Non autorisé! correspond à la source de données." & vbLf & "Saisir un autre nom de feuille.", vbCritical + vbOKOnly, "ECHEC NOM FEUILLE"
GoTo retour2
End If
If Fichier2 = Fichier1 Then
MsgBox "Modifier! Correspond à Feuille: " & Fichier1 & " déjà saisi.", vbCritical + vbOKOnly, "ECHEC NOM FEUILLE"
GoTo retour2
End If
End If
' Stop
'si utilisateur a cliqué sur Cancel pour 2 inputbox on sort de la procédure
If Fichier1 = "" Or Fichier2 = "" Then Exit Sub
'on vérifie si les noms de feuille saisis existe
If Not FExist(Fichier1) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Fichier1
Else
Sheets(Fichier1).Cells.Clear
End If
If Not FExist(Fichier2) Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Fichier2
Else
Sheets(Fichier2).Cells.Clear
End If
For Each Sht In Worksheets(Array(Fichier1, Fichier2))
With Sht
.Activate
If .Name = "Feuil3" Then
Feuille_X = "Feuil1"
Feuille_Y = "Feuil2"
Else
Feuille_X = "Feuil2"
Feuille_Y = "Feuil1"
End If
Sheets(Feuille_X).Range("A1:Z" & Sheets(Feuille_X).Range("A" & Rows.Count).End(xlUp).Row).Copy .Range("A1")
Nombre_de_colonnes = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
Ligne_vide = .Range("A" & Rows.Count).End(xlUp).Row + 1
Sheets(Feuille_Y).Range("A2:A" & Sheets(Feuille_Y).Range("A" & Rows.Count).End(xlUp).Row).Copy .Range("A" & Ligne_vide)
With .Range(.Cells(Ligne_vide, 1), .Cells(.Range("A" & Rows.Count).End(xlUp).Row, Nombre_de_colonnes)).Interior
.ThemeColor = xlThemeColorAccent2
.TintAndShade = 0.8
End With
For i = .Range("A" & Rows.Count).End(xlUp).Row To Ligne_vide Step -1
On Error Resume Next
j = Application.WorksheetFunction.Match(.Range("A" & i), .Range("A2:A" & Ligne_vide - 1), 0)
If j > 0 Then .Rows(i).Delete
j = 0
Next i
.Range("A1:Z" & Rows.Count).Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes
.Range("B2").Activate
Retour:
Do Until ActiveCell.Offset(1, 0) = ""
ActiveCell.Offset(1, 0).Activate
Loop
Ligne_du_haut = ActiveCell.Row
ActiveCell.Offset(1, 0).Activate
Do Until ActiveCell.Offset <> ""
If ActiveCell.Offset(1, -1) = "" Then GoTo fin
ActiveCell.Offset(1, 0).Activate
Loop
Ligne_du_bas = ActiveCell.Row
For k = 2 To Nombre_de_colonnes
For m = Ligne_du_haut + 1 To Ligne_du_bas - 1
Cells(m, k) = Round(Cells(Ligne_du_haut, k) + ((Cells(Ligne_du_bas, k) - Cells(Ligne_du_haut, k)) / (Cells(Ligne_du_bas, 1) - Cells(Ligne_du_haut, 1))) * (Cells(m, 1) - Cells(Ligne_du_haut, 1)), 3)
Next m
Next k
Range("B" & Ligne_du_bas).Activate
GoTo Retour
End With
fin:
Next Sht
End Sub
Function FExist(NomF As String) As Boolean ' test si la feuille existe
Application.ScreenUpdating = False
On Error Resume Next
FExist = Not Sheets(NomF) Is Nothing
Application.ScreenUpdating = True
End Function