Créer une boucle

Résolu
Pirate -  
Bonjour,

J'ai besoin de votre aide pour créer un boucle.

Pour le moment, l'utilisateur sélectionne la colonne qui porte le nom d'une feuille et le sub. 

Application.ScreenUpdating = False

Dim Im As String
Dim col As Long
Im = ActiveCell.Value
col = ActiveCell.Column

Sheets(Im).Range("B22:B52").Copy
Sheets("00.Secrétariat").Cells(8, col).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets(Im).Range("AH20").Copy
Sheets(Im).Range("AJ8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("00.Secrétariat").Cells(4, col).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("00.Secrétariat").Cells(2, col).Select
Application.CutCopyMode = False

Application.ScreenUpdating = True


Cela récupère différentes données sur la feuille en question et les copies dans la feuille 00.secrétariat. dans la colonne X.

Il a plusieurs feuilles X. J'aimerais que l'utilisateur est la possibilité de récupérer toutes les données d'un coup.

Les colonnes qui reçoivent les données vont de la colonne numéro 3 (C) à la colonne " Sheets.count"-2 (elles sont variables car on peut en rajouter).

La ligne 2 à partir de la colonne C contient le nom des onglets.

J'essaye depuis un moment de créer cette boucle mais ça dépasse mes compétences en VBA...

D'avance merci pour votre aide!!!!

2 réponses

  1.  yg_be Contributeur
    bonjour, eux-tu préciser le type "basic" quand tu emploies les balises de code pour partager du VBA?
    ci-dessous une suggestion, si j'ai bien compris. la boucle s’arrête quand elle rencontre un contenu vide en ligne 2. 
    Dim Im As String, col As Long, fsec As Worksheet

Application.ScreenUpdating = False
Set fsec = Sheets("00.Secrétariat")
col = 3
Im = fsec.Cells(2, col).Value
Do While Im <> ""
    Sheets(Im).Range("B22:B52").Copy
    Sheets("00.Secrétariat").Cells(8, col).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Sheets(Im).Range("AH20").Copy
    Sheets(Im).Range("AJ8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Sheets("00.Secrétariat").Cells(4, col).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Sheets("00.Secrétariat").Cells(2, col).Select
    col = col + 1
    Im = fsec.Cells(2, col).Value
Loop
Application.CutCopyMode = False
Application.ScreenUpdating = True

    J'ai supposé que la ligne avec les noms d'onglets était dans la feuille "00.Secrétariat". Sinon, change la ligne de code 
    fsec=
    1. Pirate
      Un grand merci ça fonctionne parfait!
      Merci!
  2. ThauTheme
    Bonjour Pirate, bonjour le forum,

    Peut-être comme ça : 
    Sub Macro1()
Dim OS As Worksheet
Dim OD As Worksheet
Dim C As Range
Dim O As Worksheet
Dim Im As String
Dim COL As Integer

Application.ScreenUpdating = False
Set OS = ActiveSheet
Set OD = Worksheets("00.Secrétariat")
COL = 3
For Each C In OS.Range(OS.Cells(2, "C"), OS.Cells(Application.Rows.Count, "C").End(xlUp))
    Im = C.Value
    Sheets(Im).Range("B22:B52").Copy
    OD.Cells(8, COL).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Sheets(Im).Range("AH20").Copy
    Sheets(Im).Range("AJ8").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    OD.Cells(4, COL).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    OD.Activate
    OD.Cells(2, COL).Select
    Application.CutCopyMode = False
    COL = COL + 1
Application.ScreenUpdating = True
End Sub