Microsoft 365 Copier depuis plusieurs pages d'un fichier une plage de colonnes entre deux cellules comportant un texte particulier

dcol = Cells(3, Columns.Count).End(1).Column

Sub boucle()



On Error Resume Next

Application.ScreenUpdating = False

Application.DisplayAlerts = False



'je suprime la feuille paste (si deja existente)

Worksheets("PASTE").Delete





'Déclare les variables



Dim Ws As Worksheet

Dim der As Long

Dim derniereligne As Long

Dim derniercolonne As Integer



'je suprime les feuilles vides





For Each Ws In Application.Worksheets

    If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then

        Ws.Delete

    End If

Next



'je suprime les images

'si autre fonction pour dire garder que text, je veux bien



Application.ScreenUpdating = False

Application.DisplayAlerts = False

For Each Ws In ActiveWorkbook.Worksheets

      For Each pic In Ws.Pictures

        pic.Delete

      Next pic

Next Ws

    

Application.ScreenUpdating = True

Application.DisplayAlerts = True



'ajoute la nouvelle Feuille PASTE tout au début du Classeur

Sheets.Add Before:=Worksheets(1)

Sheets(1).Name = "PASTE" '





'Boucle sur toutes les feuille de calcul du classeur.

'Les onglets graphiques ne sont pas pris en compte.



'ThisWorkbook correspond à l'objet classeur contenant la macro

For Each Ws In ActiveWorkbook.Worksheets

    If Ws.Name <> "PASTE" Then

   der = Worksheets("PASTE").Cells(Rows.Count, "A").End(xlUp).Row + 1

derniereligne = Ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row

derniercolonne = Ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, LookIn:=xlFormulas).Column

Ws.Range(Ws.Cells(2, derniercolonne - 10), Ws.Cells(derniereligne, derniercolonne)).Copy _

    Destination:=Worksheets("PASTE").Range("A" & der)

    End If

Next Ws



'je suprime les lignes blanche ou contenant title en A



 For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1

             If Cells(i, 1) = "" Or Cells(i, 1) = "TITLE" Then

             Rows(i).Delete

              End If

       Next i



End Sub

Option Explicit

Dim nlm&, lg2&
-----------------------------------------------------------------------------------------
Private Sub Job(i%)
  Dim coID%, dlg&
  With Worksheets(i)
    coID = .Cells(2, Columns.Count).End(1).Column - 6
    dlg = .Cells(2, coID).End(4).Row
    .Cells(2, coID).Resize(dlg - 1, 11).Copy Cells(lg2, 1)
    lg2 = lg2 + dlg - 1
    dlg = .Cells(nlm, coID).End(3).Row
    .Cells(dlg, coID).Resize(, 11).Copy Cells(lg2, 1)
    Cells(lg2, 1).Resize(, 11).Borders.LineStyle = 1
    lg2 = lg2 + 1
  End With
End Sub
--------------------------------------------------------------------------------------------

Sub CpyTbl()

Dim P As Long
Dim Ws As Worksheet

On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False

For Each Ws In Application.Worksheets
    If Application.WorksheetFunction.CountA(Ws.UsedRange) = 0 Then
        Ws.Delete
    End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True

For Each Ws In ThisWorkbook.Worksheets
    For P = Range("A65536").End(xlUp).Row To 1 Step -1
If Application.CountA(Rows(P)) = 0 Then Rows(P).Delete Shift:=xlUp

Next
Next

Sheets.Add Before:=Worksheets(1)
Sheets(1).Name = "PASTE" '

  Dim i%: Application.ScreenUpdating = 0
  Worksheets("PASTE").Select: Cells.Clear
  nlm = Rows.Count: lg2 = Cells(nlm, 1).End(3).Row + 1
  If lg2 = 2 And [A1] = "" Then lg2 = lg2 - 1
  For i = 2 To Worksheets.Count: Job i: Next i
  Cells(lg2 + 1, 1).Select: Application.CutCopyMode = 0
 
MsgBox ("MTO ESTABLISHED !")
End Sub