Aide VBA : Copier des cellules non vides ...

Aide VBA : Copier des cellules non vides ... - VB/VBA/VBS - Programmation

Marsh Posté le 27-11-2010 à 17:28:59    

Bonjour à tous!
 
Je débute en VBA, et je suis face à un petit problème prise de tête.  
 
J'ai une colonne avec un certain de cellules vides et non vides, du type :  
 
A1:
A2: TOTO
A3:
A4: TITI
A5: TUTU
A6:
A7: TATA
 
Mon objectif est générer un Sub permettant de reporter les cellules non vides l'une en dessous de l'autre dans une autre colonne, du type :
 
B1: TOTO
B2: TITI
B3: TUTU
B4: TATA
B5:
B6:
B7:
 
Ci dessous le code que j'ai réalisé :  
 
Sub Report()
'Range([H15], [H55].End(xlDown)).Select
    For Each cell In Selection
        If cell.value <> "" Then
            For i = 15 To Range("H15" ).End(xlDown).Row
            Cells(i, 9).value = cell.value
        Next
        End If
    Next cell
End Sub
 
Le souci c'est que ce code me donne un résultat du type :  
(Il balaye toute la colonne, et ajoute la dernière valeur balayer sur toutes les lignes...)
 
B1: TATA
B2: TATA
B3: TATA
B4: TATA
B5: TATA
B6: TATA
B7: TATA
 
Si vous avez une idée ?? Un grand merci par avance !! :D

Reply

Marsh Posté le 27-11-2010 à 17:28:59   

Reply

Marsh Posté le 28-11-2010 à 05:53:44    

Salut,

Option Explicit
 
Sub Tst1()
Dim LastRowA As Long
Dim i As Long, j As Long
    LastRowA = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    j = 1
 
    Application.ScreenUpdating = False
    Feuil1.Columns("B:B" ).ClearContents
    For i = 1 To LastRowA
        If Feuil1.Cells(i, 1) <> "" Then
            Feuil1.Cells(j, 2) = Feuil1.Cells(i, 1)
            j = j + 1
        End If
    Next i
    Application.ScreenUpdating = True
End Sub
 
Sub Tst2()
Dim LastRowA As Long, cA As Range
Dim i As Long
    LastRowA = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    i = 1
 
    Application.ScreenUpdating = False
    Feuil1.Columns("B:B" ).ClearContents
    For Each cA In Feuil1.Range("A1:A" & LastRowA)
        If cA.Value <> "" Then
            Feuil1.Cells(i, 2) = cA.Value
            i = i + 1
        End If
    Next cA
    Application.ScreenUpdating = True
End Sub
 
Sub Tst3()
Dim LastRowA As Long
    Application.ScreenUpdating = False
    Feuil1.Columns("B:B" ).ClearContents
    LastRowA = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    With Feuil1
        .Range("A1:A" & LastRowA).AutoFilter Field:=1, Criteria1:="<>"
        .Range("A1:A" & LastRowA).Copy .Range("B1" )
        .Range("A1:A" & LastRowA).AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub


Message édité par kiki29 le 28-11-2010 à 08:36:06
Reply

Marsh Posté le 28-11-2010 à 10:06:09    

J'ai revu le premier Sub, je n'avais pas penser à incrementer d'une autre façon! It's working! Merci!

Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed