Chronologie du collé
Bonjour à tous,
J'ai un code ci-dessous qui marche très bien pour faire 99% du travail espéré.
Il me manque juste un respect de chronologie de lignes.
Cela fait une chronologie en fonction des colonnes "X" et non pas de l'ordre des lignes.
Je ne sais pas si je suis assez clair?
Merci de votre aide.
Sub Transfert()
Dim w1 As Workbook, w2 As Workbook
Dim f1 As Worksheet, f2 As Worksheet
Dim i As Long, DerLig_w1 As Long, DerLig_w2 As Long, Deb As Long, Col As Long
Dim Chemin As String
Dim Texte1, Texte2, Texte3
Dim X As Object
Application.ScreenUpdating = False
Set w1 = ThisWorkbook
Chemin = ThisWorkbook.Path & "\"
Workbooks.Open Filename:=Chemin & "Transfert.xlsx"
Set w2 = ActiveWorkbook
Set f2 = Sheets("Checklist Document")
DerLig_w2 = f2.Range("A" & Rows.Count).End(xlUp).Row
w1.Activate
Set f1 = Sheets("2- Questionnaire")
DerLig_w1 = f1.Range("E" & Rows.Count).End(xlUp).Row
With f1.Range("P14:Q" & DerLig_w1)
Set X = .Find("X")
If Not X Is Nothing Then
Deb = X.Row
Col = X.Column
Do
If f1.Cells(X.Row, Col).MergeCells Then
Texte1 = f1.Cells(X.Row, "E")
Texte2 = f1.Cells(X.Row + 1, "E")
Texte3 = f1.Cells(X.Row, "I")
w2.Activate
Range(f2.Cells(DerLig_w2 + 1, "A"), f2.Cells(DerLig_w2 + 1, "D")).Value = Array(Texte1, Texte2, "", Texte3)
DerLig_w2 = DerLig_w2 + 1
Else
Texte1 = f1.Cells(X.Row, "E")
Texte3 = f1.Cells(X.Row, "I")
w2.Activate
Range(f2.Cells(DerLig_w2 + 1, "A"), f2.Cells(DerLig_w2 + 1, "D")).Value = Array(Texte1, "", "", Texte3)
DerLig_w2 = DerLig_w2 + 1
End If
w1.Activate
Set X = .FindNext(X)
Loop While Not X Is Nothing And X.Row <> Deb
End If
Sheets("1-Synthese et Resultats").Select
Range("AB17").Select
Selection.Copy
Windows("Transfert.xlsx").Activate
Range("C1:D1").Select
ActiveSheet.Paste
Windows("GRF-0124.xlsm").Activate
End With
w2.Activate
f2.Range("B2:B" & DerLig_w2).Font.Color = RGB(0, 0, 255)
w2.Close
Set w1 = Nothing
Set w2 = Nothing
Set f1 = Nothing
Set f2 = Nothing
Set X = Nothing
End Sub