Macro de regroupement de feuilles de calcul generique

[1yakka]

Bonjour,

Je me lance dans la réalisation d'une macro générique de regroupement de feuille de calcul.
Sauf que je suis vraiment "rouillé" en VBA. (j'ai dejà des problèmes avec les select...)

J'ai un fichier Excel qui a été extrait d'un PDF qui contient différents tableaux.
Ce fichier contient x feuilles nommées Table1 Table2 ... Tablex

Vu que je vais devoir retravailler ce fichier Excel chaque fois que je recevrais la nouvelle version du PDF je souhaitais faire une macro générique me permettant de regrouper par exemple les feuilles de 5 à 50 en une feuille en configurant le numero de la première ligne à prendre.

Je vais me lancer mais j'ouvre un post de suite car je sais que je vais galérer, mais surtout si quelqu'un a dejà fait quelque chose de similaire et veut bien partager, je suis preneur. 😎

Ci joint un exemple ou je veux regrouper les tables 1 à 3 dans une feuille et les tables 4 à 5 dans une autre feuille


Merci d'avance

 

[Lolote83]

Re : Macro de regroupement de feuilles de calcul generique

Salut 1yakka,
En espérant avoir compris ta demande.
Voir ici
Cordialement
Lolote83

 

[1yakka]

Re : Macro de regroupement de feuilles de calcul generique

Merci

J'ai modifié la macro pour la rendre configurable.
Voici le résultat
Sub Regroupement()
Dim arrayTemp As Variant
Dim NumOng, NumOngDeb, NumOngFin As Integer
xOngDeb = [B1]
arrayTemp = Split(xOngDeb, " ")
NumOngDeb = Val(arrayTemp(1))
xOngFin = [B2]
arrayTemp = Split(xOngFin, " ")
NumOngFin = Val(arrayTemp(1))
xDerColonne = [B3]
xColonneNonVide = [B4]
xTitre = [B5]
xPremLigne = [B6]
xCpt = 0
[A9:K65536].ClearContents
If NumOngDeb >= NumOngFin Then
xMess = Empty
xMess = xMess & "L'ordre n'est pas respecté !!!"
MsgBox xMess, vbInformation, "ORDRE CROISSANT"
Else
For Each xOng In Worksheets
arrayTemp = Split(xOng.Name, " ")
NumOng = Val(arrayTemp(1))
Select Case NumOng
'Select Case xOng.Name
Case Is = 0
'Case Is = "RECUP1"
Exit For
Case Is >= NumOngDeb
'Case Is >= xOngDeb
If xOng.Name = xOngDeb Then
Sheets(xOng.Name).Range("A" & xTitre & ":" & xDerColonne & xPremLigne).Copy Sheets("RECUP1").Range("A8")
End If
If NumOng <= NumOngFin Then
With Sheets(xOng.Name)
xDerligTable = .Range(xColonneNonVide & "65536").End(xlUp).Row
xDerligParam = Sheets("RECUP1").Range(xColonneNonVide & "65536").End(xlUp).Row + 1
'.Range("A2:K" & xDerligTable).Copy Sheets("RECUP1").Range("A" & xDerligParam)
.Range("A" & (xPremLigne) & ":" & xDerColonne & xDerligTable).Copy Sheets("RECUP1").Range("A" & xDerligParam)
End With
End If
If xOng.Name = xOngFin Then
Exit For
End If
End Select
Next
End If
End Sub

1Yakka