Option Explicit
Option Compare Text
Sub TheUltimatorRecuperator()
Dim WS As Worksheet
Dim WSArray() As Variant
Dim TabloPlage As Variant
Dim TabloData() As String
Dim L As Integer, x As Integer
Dim C As Byte, Col As Byte, y As Byte, w As Byte
Dim WSSource As Worksheet
Set WSSource = ThisWorkbook.Worksheets('W')
With WSSource
TabloPlage = .Range('A1:H' & .Range('a65536').End(xlUp).Row)
End With
If UBound(TabloPlage) <= 1 Then
MsgBox 'Aucune donnée à traîter en Feuille ' & WSSource.Name, vbCritical, 'Et Boum !!! lol @+Thierry'
Exit Sub
End If
For Each WS In ThisWorkbook.Worksheets
If WS.Name <> WSSource.Name Then
ReDim Preserve WSArray(w)
WSArray(w) = WS.Name
w = w + 1
End If
Next
For L = 1 To UBound(TabloPlage)
For C = 1 To 8
For y = 0 To UBound(WSArray)
If Not IsError(TabloPlage(L, C)) Then
If TabloPlage(L, C) = WSArray(y) Then
ReDim Preserve TabloData(8, x)
For Col = 0 To 7
TabloData(Col, x) = TabloPlage(L, Col + 1)
Next Col
TabloData(8, x) = WSArray(y)
x = x + 1
End If
End If
Next y
Next C
Next L
If x = 0 Then
MsgBox 'Aucune donnée correspondante retournée depuis Feuille : ' & WSSource.Name, vbInformation, 'Et Paf !!! lol @+Thierry'
Exit Sub
End If
For x = 0 To UBound(TabloData, 2)
For y = 0 To UBound(WSArray)
If TabloData(8, x) = WSArray(y) Then
With Sheets(WSArray(y))
L = .Range('A35000').End(xlUp).Row + 1
For C = 0 To 7
.Cells(L, C + 1) = TabloData(C, x)
Next
End With
End If
Next y
Next x
End Sub
