XL 2010 une macro pour transférer un tableau

  • Initiateur de la discussion Initiateur de la discussion stefer
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

stefer

XLDnaute Junior
Bonjour,
J'ai un tableau dans la feuil1 et je voudrais avec un bouton pouvoir transférer simplement sur la feuil2 certaine colonne (2à7).
Merci de vos réponses
 

Pièces jointes

Bonsoir.
Comme ça ?
VB:
Sub Transfere()
Dim TSrc(), LSrc&, TCbl(), LCbl&, C&
TSrc = Intersect(Feuil1.Rows(4).Resize(1000000), Feuil1.UsedRange).Value
ReDim TCbl(1 To UBound(TSrc, 1), 1 To 6)
For LSrc = 1 To UBound(TSrc, 1)
   If VarType(TSrc(LSrc, 8)) <> vbDate Then
      LCbl = LCbl + 1
      For C = 1 To 6: TCbl(LCbl, C) = TSrc(LSrc, C + 1): Next C: End If: Next LSrc
Feuil2.[A4].Resize(1000000).ClearContents
Feuil2.[A4].Resize(LCbl, 6).Value = TCbl
End Sub
 
Bonsoir,
Oui c'est l'idée merci par contre il y a des ligne qui se multiplie dans la feuil2
Pour vous montrer la feuil1 cest les lignes jaunes qui doivent etre transférées mais certaine se multiplie jai fait plein dessai en changeant les dates et il y a des lignes qui se multiplie.
merci d'avance
 

Pièces jointes

Oublié d'effacer le reste de colonnes. Comme ça on efface les lignes entières :
VB:
Sub Transfere()
Dim TSrc(), LSrc&, TCbl(), LCbl&, C&
TSrc = Intersect(Feuil1.Rows(4).Resize(1000000), Feuil1.UsedRange).Value
ReDim TCbl(1 To UBound(TSrc, 1), 1 To 6)
For LSrc = 1 To UBound(TSrc, 1)
   If VarType(TSrc(LSrc, 8)) <> vbDate Then
      LCbl = LCbl + 1
      For C = 1 To 6: TCbl(LCbl, C) = TSrc(LSrc, C + 1): Next C: End If: Next LSrc
Feuil2.Rows(4).Resize(1000000).ClearContents
Feuil2.[A4].Resize(LCbl, 6).Value = TCbl
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
1
Affichages
249
Réponses
18
Affichages
185
Réponses
11
Affichages
219
Retour