Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

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
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

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
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

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

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 .
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
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

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, ç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
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Question
XL 2021 Besoin de conseils pour une sélection de multiples éléments
2
Réponses
18
Affichages
1 K
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
437
Caradel
C
P
  • Question
XL 2019 Bloquer la saisie dans une colonne sous condition
Réponses
1
Affichages
479
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
  • 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
E
  • Résolu(e)
Microsoft 365 Problème d'organisation des colonnes dans une ListBox en VBA Excel
Réponses
2
Affichages
795
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
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…