copier coller les colonnes non vides avec vba excel

Version imprimable

24/10/2019, 11h14
Invité

2 pièce(s) jointe(s)

copier coller les colonnes non vides avec vba excel

bonjour
j'ai un classeur excel où des colonnes vides et des colonnes non vides comme sur l'image
Pièce jointe 512822
remarques: les colonnes non vides ne sont pas les mêmes
je voudrai copier et les coller les colonnes non vide dans une autre page à l'aide de code VBA
Pièce jointe 512823
aidez moi s'il vous plais
merci

salam khouya, bonjour la forum
à tester :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub test()
Dim FBASE As Worksheet
Dim Fdest As Worksheet
Dim dercol As Long
Application.ScreenUpdating = False
Set FBASE = Sheets("Feuil1")
Set Fdest = Sheets("Feuil2")
'Nettoyer la feuille de destination
    Fdest.Cells.ClearContents
C = 1
L = 1
dercol = FBASE.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For C = 1 To dercol
 X = Application.CountA(Columns(C))
If X <> 0 Then
FBASE.Columns(C).Copy Fdest.Columns(L)
L = L + 1
End If
Next C
MsgBox "Données Copiées"
Fdest.Select
Application.ScreenUpdating = True
End Sub

24/10/2019, 12h25
Menhir

Autre proposition :

Code:

Rows(1).SpecialCells(xlCellTypeConstants).EntireColumn.Copy WS_Dest.Range("A1")

En remplaçant WS_Dest par la référence à l'onglet de destination de la copie.

1 pièce(s) jointe(s)

voici ce que donne

Citation:

Envoyé par BENNASR

salam khouya, bonjour la forum
à tester :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub test()
Dim FBASE As Worksheet
Dim Fdest As Worksheet
Dim dercol As Long
Application.ScreenUpdating = False
Set FBASE = Sheets("Feuil1")
Set Fdest = Sheets("Feuil2")
'Nettoyer la feuille de destination
    Fdest.Cells.ClearContents
C = 1
L = 1
dercol = FBASE.Cells(1, Cells.Columns.Count).End(xlToLeft).Column
For C = 1 To dercol
 X = Application.CountA(Columns(C))
If X <> 0 Then
FBASE.Columns(C).Copy Fdest.Columns(L)
L = L + 1
End If
Next C
MsgBox "Données Copiées"
Fdest.Select
Application.ScreenUpdating = True
End Sub

Pièce jointe 512891

24/10/2019, 15h24
BENNASR

1 pièce(s) jointe(s)

peut être une erreur de votre part

mais la proposition de Menhir est meilleure à mon avis :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub test()
Dim FBASE As Worksheet
Dim Fdest As Worksheet
Dim dercol As Long
Application.ScreenUpdating = False
Set FBASE = Sheets("Feuil1")
Set Fdest = Sheets("Feuil2")
'Nettoyer la feuille de destination
    Fdest.Cells.ClearContents
FBASE.Rows(1).SpecialCells(xlCellTypeConstants).EntireColumn.Copy Fdest.Range("A1")
Fdest.Select
Application.ScreenUpdating = True
End Sub

24/10/2019, 18h06
Invité

1 pièce(s) jointe(s)

merci pour votre reponse

vous pouvez m'aider à faire la même chose sur le fichier suivant?
Pièce jointe 512946
25/10/2019, 09h30
BENNASR

Cher ami, à mon modeste avis et quand tu reçois une réponse qui résout et/ou t’aide à résoudre un problème, la moindre des choses dire MERCI et non pas cliquer sur RESOLU et quitter sans aucun mot !!! Pour cette raison je quitte cette discussion