Microsoft 365 Code VBA pour sélectionner une colonne sur 4

I

infernotronic

XLDnaute Nouveau
Bonjour à tous,

Je cherche le moyen, en VBA, de sélectionner une plage de cellule avec ces critères :
Dans un onglet : Sélection des lignes 7 à 173 d'une colonne sur 4, en partant de la colonne H et cela jusqu'à la dernière colonne avec des valeurs.
Dans un autre onglet : copie des valeurs sélectionnées en les transposant à l'horizontal.

ChatGPT sèche sur la sélection d'une colonne sur 4... et moi je ne sais pas faire ;)

Quelqu'un pourrait-il m'aider s'il vous plait, en espérant que ma question soit compréhensible ?

Merci par avance
 
Trier par date Trier par votes
I

infernotronic

XLDnaute Nouveau
Staple1600 à dit:
Bonsoir le fil,

@infernotronic
Avant d'aller titiller ChatGPT, pourquoi ne pas tenter l'enregistreur de macros intégré à Excel ?
Cliquez pour agrandir...
C'est ce que j'ai fait mais cela reviendrait à faire une macro qui serait à rallonge car j'ai de nombreuses colonnes dans le fichier.

Cela donnerait un truc du genre :
Range("H7:H173,L7:L173,P7: P173,T7:T173,X7:X173,AB7:AB173,AF7:AF173,AJ7:AJ173,... jusqu'à plus soif").Select

Je suis persuadé qu'il y a possibilité de faire cela simplement avec une boucle ou autre astuce du genre.
Malheureusement je ne suis pas assez calé pour y arriver seul 😭
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

Question:
Est-ce que la sélection est obligatoire ?
Car cette boucle parcourt les colonnes par exemple

Code: 
Sub test()
Dim i&, dercol&
dercol = Cells(7, Columns.Count).End(xlToLeft).Column
For i = 1 To dercol Step 4
MsgBox Cells(7, i).Resize(167).Address
Next
End Sub
 
Vote positif 0 Vote négatif
I

infernotronic

XLDnaute Nouveau
Staple1600 à dit:
Re

Question:
Est-ce que la sélection est obligatoire ?
Car cette boucle parcourt les colonnes par exemple

Code: 
Sub test()
Dim i&, dercol&
dercol = Cells(7, Columns.Count).End(xlToLeft).Column
For i = 1 To dercol Step 4
MsgBox Cells(7, i).Resize(167).Address
Next
End Sub
Cliquez pour agrandir...
La sélection est obligatoire car les valeurs sélectionnées sont à copier dans un autre onglet.
 
Vote positif 0 Vote négatif
I

infernotronic

XLDnaute Nouveau
Cette macro fonctionne presque bien !
Ne manque que le fait qu'elle s'arrête à quatre colonnes nommées et non à une sélection automatique de l'ensemble des colonnes souhaitées, soit une toutes les quatre colonnes en partant de la colonne H.

Private Sub CommandButton1_Click()

Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim lastRow As Long
Dim sourceRange As Range
Dim destinationRange As Range

' Définir les feuilles sources et de destination
Set wsSource = ThisWorkbook.Worksheets("Feuil1")
Set wsDestination = ThisWorkbook.Worksheets("Feuil2")

' Déterminer la dernière ligne de la feuille source
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row

' Définir la plage source
Set sourceRange = wsSource.Range("H7:H" & lastRow & ", L7:L" & lastRow & ", P7: P" & lastRow & ", T7:T" & lastRow)

' Définir la plage de destination
Set destinationRange = wsDestination.Range("A3")

' Copier le texte à l'horizontale
sourceRange.Copy
destinationRange.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

' Effacer le presse-papiers
Application.CutCopyMode = False

' Optionnel : ajuster la largeur des colonnes de destination pour afficher le texte
wsDestination.UsedRange.Columns.AutoFit

MsgBox "Copie terminée avec succès!"

End Sub
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re

C'est ce que tu souhaites faire ?
(Si oui, je n'ai pas mis de Select dans le code ;)
VB: 
Sub test_B()
Dim i&, dercol&
dercol = Cells(7, Columns.Count).End(xlToLeft).Column
j = 0
For i = 8 To dercol Step 4
Cells(7, i).Resize(167).Copy
Feuil2.Range("A3").Offset(, j).PasteSpecial Paste:=xlPasteValues
j = j + 1
Next
End Sub
 
Vote positif 0 Vote négatif
I

infernotronic

XLDnaute Nouveau
Staple1600 à dit:
Re

C'est ce que tu souhaites faire ?
(Si oui, je n'ai pas mis de Select dans le code ;)
VB: 
Sub test_B()
Dim i&, dercol&
dercol = Cells(7, Columns.Count).End(xlToLeft).Column
j = 0
For i = 8 To dercol Step 4
Cells(7, i).Resize(167).Copy
Feuil2.Range("A3").Offset(, j).PasteSpecial Paste:=xlPasteValues
j = j + 1
Next
End Sub
Cliquez pour agrandir...
J'essaie de le faire fonctionner seul ou de l'intégrer dans la macro ci-dessus mais cela ne fonctionne pas.
Peut-être que je me débrouille mal ?

Sub test_B()

Dim i&, dercol&

dercol = ThisWorkbook.Worksheets("Feuil1").Cells(7, Columns.Count).End(xlToLeft).column
j = 0
For i = 8 To dercol Step 4
Cells(7, i).Resize(167).Copy
ThisWorkbook.Worksheets("Feuil2").Range("A3").Offset(, j).PasteSpecial Paste:=xlPasteValues
j = j + 1
Next

End Sub
 
Vote positif 0 Vote négatif
Staple1600

Staple1600

XLDnaute Barbatruc
Re


Il faut la faire fonctionner seule
Pour tester, j'ai pris un classeur avec deux feuilles
(Les données à recopier sont sur la feuille 1)
En étant sur la feuille 1, quand on lance la macro, les données sont recopiées sur la feuille 2
(En prenant les données, toutes les 4 colonnes à partir de la colonne H)

Ton code devrait être celui-ci dans ce cas.
Code: 
Sub test_B()
Dim i&, dercol&
dercol = ThisWorkbook.Worksheets("Feuil1").Cells(7, Columns.Count).End(xlToLeft).column
j = 0
For i = 8 To dercol Step 4
ThisWorkbook.Worksheets("Feuil1").Cells(7, i).Resize(167).Copy
ThisWorkbook.Worksheets("Feuil2").Range("A3").Offset(, j).PasteSpecial Paste:=xlPasteValues
j = j + 1
Next
End Sub
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour à tous ,

Le code à la noix de mapomme dans module1😜.
Je n'ai pas supposé que la première ligne est une ligne de titre donc la ligne 7 n'est pas forcément la plus longue. Un fichier joint eut permis de lever le doute :rolleyes:.
La procédure copie les valeurs et les formats.
Le code dans module1 :
VB: 
Sub Transposer1sur4()
Dim dercol&, n&, i&, j&
   With Sheets("Feuil1")
      For j = .UsedRange.Column + .UsedRange.Columns.Count - 1 To 8 Step -1
         n = Application.WorksheetFunction.CountA(.Range(.Cells(7, j), .Cells(173, j)))
         If n > 0 Then dercol = j: Exit For
      Next j
      If dercol = 0 Then MsgBox ("Rien à copier"): Exit Sub
      Application.ScreenUpdating = False: n = 0
      For j = 8 To dercol Step 4
         .Range(.Cells(7, j), .Cells(173, j)).Copy
         With Worksheets("Feuil2")
            n = n + 1
            .Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Cells(n, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
         End With
      Next j
   End With
   Application.CutCopyMode = False
   Application.Goto Worksheets("Feuil2").Range("A1"), True
End Sub
 

Pièces jointes

  • infernotronic- 1 col sur 4- v1.xlsm
    70.4 KB · Affichages: 9
Vote positif 0 Vote négatif
I

infernotronic

XLDnaute Nouveau
mapomme à dit:
Bonjour à tous ,

Le code à la noix de mapomme dans module1😜.
Je n'ai pas supposé que la première ligne est une ligne de titre donc la ligne 7 n'est pas forcément la plus longue. Un fichier joint eut permis de lever le doute :rolleyes:.
La procédure copie les valeurs et les formats.
Le code dans module1 :
VB: 
Sub Transposer1sur4()
Dim dercol&, n&, i&, j&
   With Sheets("Feuil1")
      For j = .UsedRange.Column + .UsedRange.Columns.Count - 1 To 8 Step -1
         n = Application.WorksheetFunction.CountA(.Range(.Cells(7, j), .Cells(173, j)))
         If n > 0 Then dercol = j: Exit For
      Next j
      If dercol = 0 Then MsgBox ("Rien à copier"): Exit Sub
      Application.ScreenUpdating = False: n = 0
      For j = 8 To dercol Step 4
         .Range(.Cells(7, j), .Cells(173, j)).Copy
         With Worksheets("Feuil2")
            n = n + 1
            .Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Cells(n, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
         End With
      Next j
   End With
   Application.CutCopyMode = False
   Application.Goto Worksheets("Feuil2").Range("A1"), True
End Sub
Cliquez pour agrandir...
Salut Mapomme ;)

Ton code s'approche de très près à ce que je souhaite faire. Merci déjà pour ce grand pas en avant ;)

Pour parfaire le code, voici quelques précisions :
Dans la feuille 2 la copie doit commencer à la cellule A3 (J'ai fait cela en modifiant la ligne n=n+3 ) mais ensuite je constate qu'en ayant cette modification cela provoque un collage des lignes après la première avec un décalage de 3 au lieu de coller sans ligne intercalaire.

VB: 
Sub Transposer1sur4()
Dim dercol&, n&, i&, j&
   With Sheets("Feuil1")
      For j = .UsedRange.Column + .UsedRange.Columns.Count - 1 To 8 Step -1
         n = Application.WorksheetFunction.CountA(.Range(.Cells(7, j), .Cells(173, j)))
         If n > 0 Then dercol = j: Exit For
      Next j
      If dercol = 0 Then MsgBox ("Rien à copier"): Exit Sub
      Application.ScreenUpdating = False: n = 0
      For j = 8 To dercol Step 4
         .Range(.Cells(7, j), .Cells(173, j)).Copy
         With Worksheets("Feuil2")
            n = n + [S][COLOR=rgb(226, 80, 65)]1[/COLOR][/S] [/I][COLOR=rgb(97, 189, 109)][I]3[/I][/COLOR]
[I]            .Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            [S][COLOR=rgb(226, 80, 65)].Cells(n, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False,[/COLOR][/S] [S][COLOR=rgb(226, 80, 65)]Transpose:=True[/COLOR][/S]
         End With
      Next j
   End With
   Application.CutCopyMode = False
   Application.Goto Worksheets("Feuil2").Range("A1"), True
End Sub

As-tu une idée pour corriger cela ?
 
Vote positif 0 Vote négatif
mapomme

mapomme

XLDnaute Barbatruc
Supporter XLD
Reb ;) ,
Essaye ce code. La ligne modifiée a un commentaire.
VB: 
Sub Transposer1sur4()
Dim dercol&, n&, i&, j&
   With Sheets("Feuil1")
      For j = .UsedRange.Column + .UsedRange.Columns.Count - 1 To 8 Step -1
         n = Application.WorksheetFunction.CountA(.Range(.Cells(7, j), .Cells(173, j)))
         If n > 0 Then dercol = j: Exit For
      Next j
      If dercol = 0 Then MsgBox ("Rien à copier"): Exit Sub
      Application.ScreenUpdating = False: n = 2 '<<<<< MODIF
      For j = 8 To dercol Step 4
         .Range(.Cells(7, j), .Cells(173, j)).Copy
         With Worksheets("Feuil2")
            n = n + 1
            .Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Cells(n, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
         End With
      Next j
   End With
   Application.CutCopyMode = False
   Application.Goto Worksheets("Feuil2").Range("A1"), True
End Sub
 
Vote positif 0 Vote négatif
I

infernotronic

XLDnaute Nouveau
mapomme à dit:
Reb ;) ,
Essaye ce code. La ligne modifiée a un commentaire.
VB: 
Sub Transposer1sur4()
Dim dercol&, n&, i&, j&
   With Sheets("Feuil1")
      For j = .UsedRange.Column + .UsedRange.Columns.Count - 1 To 8 Step -1
         n = Application.WorksheetFunction.CountA(.Range(.Cells(7, j), .Cells(173, j)))
         If n > 0 Then dercol = j: Exit For
      Next j
      If dercol = 0 Then MsgBox ("Rien à copier"): Exit Sub
      Application.ScreenUpdating = False: n = 2 '<<<<< MODIF
      For j = 8 To dercol Step 4
         .Range(.Cells(7, j), .Cells(173, j)).Copy
         With Worksheets("Feuil2")
            n = n + 1
            .Cells(n, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            .Cells(n, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
         End With
      Next j
   End With
   Application.CutCopyMode = False
   Application.Goto Worksheets("Feuil2").Range("A1"), True
End Sub
Cliquez pour agrandir...
Mapomme, ça fonctionne. Tu es au top !!

Merci beaucoup pour le temps passé. Je vais tenter de bien tout comprendre ce que tu as créer histoire de pouvoir le renouveler le cas échéant ;)
 
Vote positif 0 Vote négatif

Discussions similaires

jeff1494
  • Question
XL 2021 Besoin de conseils pour une sélection de multiples éléments
2
Réponses
18
Affichages
1 K
jeff1494
jeff1494
P
  • Question
XL 2021 Code VBA pour copier coller des données de cellules d'une feuille a une autre
Réponses
4
Affichages
577
phoceenjo
P
L
  • Résolu(e)
Microsoft 365 Création d'un code VBA pour sélectionner des zone selon choix multiples.
Réponses
3
Affichages
406
Lionel Alfred
L
C
  • Question
XL 2016 VBA - Copier des valeurs par tranche
Réponses
4
Affichages
436
Caradel
C
P
  • Question
XL 2019 Bloquer la saisie dans une colonne sous condition
Réponses
1
Affichages
478
sylvanu
sylvanu
C
  • Résolu(e)
Autres code barre dans textbox pour sélectionner ligne a afficher dans listbox
2 3
Réponses
33
Affichages
2 K
herve62
herve62
PatFr38
  • Résolu(e)
Microsoft 365 Masquer des colonnes aux cellules avec valeurs données selon sélection d'une liste déroulante
Réponses
5
Affichages
798
PatFr38
PatFr38
E
  • Résolu(e)
Microsoft 365 Problème d'organisation des colonnes dans une ListBox en VBA Excel
Réponses
2
Affichages
794
eCHO
E
N
  • Résolu(e)
Microsoft 365 Fonction FILTRE multicritères (SANS VBA)
Réponses
4
Affichages
1 K
nicolasdhv
N
T
  • Résolu(e)
Microsoft 365 VBA code filtre auto en boucle - plusieurs critères
2
Réponses
28
Affichages
2 K
tnion
T

Membres actuellement en ligne

2 membres et 74 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 087
Messages
2 116 082
Membres
112 653
dernier inscrit
flapynot7x