Aide pour ne pas utiliser les .select : VBA n'a pas de souris ;-)

Version imprimable

Merci à toutes les personnes qui m'ont apporté leur aide et des liens vers des tutoriels, guides et documentation de formation.

Cela aide beaucoup ! :D

Cependant je bloque toujours pour ne pas utiliser des

Code:

.Select

Pour expliquer le besoin, j'ai un fichier Excel de référence qui sert de base de données (il sera à terme transformé en une véritable base de données): 9000 lignes et 300 colonnes.
Pour un ensemble de besoins, l'utilisateur trie les données de cette table grâce aux filtres. Cela permet d'afficher par exemple 3 lignes.

Ces 3 lignes et certaines des 300 colonnes seront transférées vers un autre tableau dans un autre fichier qui comporte des colonnes en plus (d'où le IF TransColP = "" Then).

Le tout étant vivant, le nom des colonnes peut changer !
Sur un onglet du fichier portant la macro, dans une autre feuille, un troisième tableau permet d'indiquer (transcodifier) le nom des colonnes des deux tableaux.
Par exemple: Dénomination (base de données) vs Référence (fichier de travail)

T_Ref.Port.TC:

N.Col.conv.TC N.Col.conv.Po

Dénomination Référence

Marque. Trademark

Type d'appar. Type d'appareil

...

La macro va donc traiter colonne par colonne pour copier l'ensemble des données vers le tableau final.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 Option Explicit Sub Extraction() Application.ScreenUpdating = False Dim Message As Integer Dim NomClasseur As String Dim TransColP As Range Dim LienColTC As String Dim NomCol As String Dim RefnbLigne As Integer NomClasseur = ActiveWorkbook.name For Each TransColP In Workbooks(NomClasseur).Sheets("Listes").Range("T_Ref.Port.TC[[N.Col.conv.Po]]") If TransColP = "" Then Else RefnbLigne = TransColP.Row - 1 NomCol = TransColP.Text NomCol = "Tableau4[[" & NomCol & "]]" LienColTC = Workbooks(NomClasseur).Sheets("Listes").ListObjects("T_Ref.Port.TC").ListColumns("N.Col.conv.TC").DataBodyRange(RefnbLigne) LienColTC = "T_Tableau_TC[[" & LienColTC & "]]" Workbooks("Portail données.xlsx").Sheets("CHOD").Activate Range(NomCol).Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Workbooks(NomClasseur).Sheets("TableauCaractéristiques").Activate Range(LienColTC).Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False End If Next TransColP Application.ScreenUpdating = True End Sub

22/08/2022, 18h19
mat955
Bonjour,

Bien souvent, il suffit de "contracter" les écritures.
Par exemple, on peu remplacer :
Code:

1 2 Range("A1").select Selection.PasteSpecial XlPasteValues
Par :

Code:

Range("A1").PasteSpecial XlPasteValues

Autre chose d'intéressant quand on utilise des filtres, il est possible en une seule instruction de sélectionner/copier uniquement les cellules visibles (= celles qui restent après avoir filtré), par exemple :

Code:

Columns("A:C").SpecialCells(xlCellTypeVisible)

N.Col.conv.TC	N.Col.conv.Po
Dénomination	Référence
Marque.	Trademark
Type d'appar.	Type d'appareil
...

Merci pour ces conseils Mat995

Cela fonctione :-D

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
    For Each TransColP In Workbooks(NomClasseur).Sheets("Listes").Range("T_Ref.Port.TC[[N.Col.conv.Po]]")
        If TransColP = "" Then
            Else
            RefnbLigne = TransColP.Row - 1
            NomCol = TransColP.Text
            NomCol = "Tableau4[[" & NomCol & "]]"
            LienColTC = Workbooks(NomClasseur).Sheets("Listes").ListObjects("T_Ref.Port.TC").ListColumns("N.Col.conv.TC").DataBodyRange(RefnbLigne)
            LienColTC = "T_Tableau_TC[[" & LienColTC & "]]"
            Workbooks("Portail données.xlsx").Sheets("CHOD").Range(NomCol).SpecialCells(xlCellTypeVisible).Copy
 
            Workbooks(NomClasseur).Sheets("TableauCaractéristiques").Range(LienColTC).PasteSpecial _
            Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Workbooks(NomClasseur).Sheets("TableauCaractéristiques").Range(LienColTC).PasteSpecial _
            Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 
        End If
    Next TransColP

25/08/2022, 13h41
LabCert

Citation:

LabCert;11867360]Merci pour ces conseils Mat995

Cela fonctione :-D

Oui, mes excuses à ceux qui auraient le message avant la mise à jour. J'avais une erreur de typographie.