Macro pour extraire plusieurs cellules d'un onglet

vidou · 24 Mars 2015

Bonjour,

J'ai écrit ce code pour commencer à extraire les données d'un onglet vers un autre

Ici, en fonction de la donnée en colonne A, je copie les données de la 4eme colonne dans la colonne C d'un autre onglet

Et je voudrais un balayage des lignes pour mettre par exemple colonne E dans colonne C, puis colonne F dans colonne B.......

Pourriez vous m'indiquer ce que je dois ajouter au code !

Merci

HTML:

Sub Extraction_commande()


Dim tabCom(1000) As String
Dim y As Integer

Worksheets("COM").Select
Range("A2571").Select

'Chargement de mon tabFax
While ActiveCell.Value <> ""

    If ActiveCell.Offset(0, 0).Value = "COM" Then
       
       y = y + 1
       tabCom(y) = ActiveCell.Offset(0, 4).Value
    
    End If
    
ActiveCell.Offset(1, 0).Select

Wend

Worksheets("2KE_SDS").Select
Range("C1").Value = "ENTRETIEN"
Range("C2").Select


For i = 1 To y

    ActiveCell.Value = tabCom(i)
    ActiveCell.Offset(1, 0).Select
Next i



End Sub

Bebere · 24 Mars 2015

Re : Macro pour extraire plusieurs cellules d'un onglet

bonjour vidou,le forum
un petit fichier exemple serait intéressant(tester le code)
ton code amélioré
pour ta demande colonne E dans colonne C, puis colonne F dans colonne B
sur quel critère

Code:

Sub Extraction_commande()


Dim tabCom() As String
Dim y As Long, cel As Range

Worksheets("COM").Activate
Set cel = Range("A2571")

'Chargement de mon tabFax
While cel.Value <> ""

    If cel.Value = "COM" Then
       ReDim Preserve tabCom(y)
       tabCom(y) = cel.Offset(0, 4).Value
           y = y + 1
    End If
    
Set cel = cel.Offset(1, 0)

Wend

Worksheets("2KE_SDS").Activate
Range("C1").Value = "ENTRETIEN"
'Range("C2").Select

For y = LBound(tabCom) To UBound(tabCom)
Range("C" & y + 2) = tabCom(i)
'    ActiveCell.Value = tabCom(i)
'    ActiveCell.Offset(1, 0).Select
Next y



End Sub

vidou · 24 Mars 2015

Re : Macro pour extraire plusieurs cellules d'un onglet

Bonjour,

Pour le fichie il est trop gros !

Le critère est toujours le meme

J'ai donc bidouiller ceci sachant que l'onglet de base va s'incrmenter au fil de l'anée et je voudrais ne copier que les nouvelles données à chaque mise à jour

J'ai aussi un bouton mise à jour qui appelle la macro

Ne sachant pas comment ne mettre a joru que ce qui est ajouter dans la base, j'ai crée une marco qui supprime tout ( les colonnes concernées ) et qui colle toutes les données

Mais pouvez vous peut être m'aider à arranger cela

Merci

HTML:

Sub Extraction_commande()


Dim tabCom(10000, 15) As Variant
Dim y As Integer

' supprimer les données de 2KE_SDS

Worksheets("2KE_SDS").Select

Call supp_extraction



Worksheets("COM").Select
Range("A2571").Select

'Copie des données dans le tableau virtuel commande
While ActiveCell.Value <> ""

    If ActiveCell.Offset(0, 0).Value = "COM" Then
       
       y = y + 1
        tabCom(y, 1) = ActiveCell.Offset(0, 13).Value
        tabCom(y, 2) = ActiveCell.Offset(0, 3).Value
        tabCom(y, 3) = ActiveCell.Offset(0, 12).Value
        tabCom(y, 4) = ActiveCell.Offset(0, 4).Value
        tabCom(y, 5) = ActiveCell.Offset(0, 14).Value
        tabCom(y, 6) = ActiveCell.Offset(0, 1).Value
        tabCom(y, 7) = ActiveCell.Offset(0, 18).Value
        tabCom(y, 8) = ActiveCell.Offset(0, 11).Value
        tabCom(y, 9) = ActiveCell.Offset(0, 15).Value
        tabCom(y, 10) = ActiveCell.Offset(0, 6).Value
     
    End If
    
ActiveCell.Offset(1, 0).Select

Wend

Worksheets("2KE_SDS").Select
Range("A2").Select

For i = 1 To y

    ActiveCell.Offset(0, 2).Value = tabCom(i, 1)
    ActiveCell.Offset(0, 5).Value = tabCom(i, 2)
    ActiveCell.Offset(0, 6).Value = tabCom(i, 3)
    ActiveCell.Offset(0, 7).Value = tabCom(i, 4)
    ActiveCell.Offset(0, 8).Value = tabCom(i, 5)
    ActiveCell.Offset(0, 9).Value = tabCom(i, 6)
    ActiveCell.Offset(0, 10).Value = tabCom(i, 7)
    ActiveCell.Offset(0, 14).Value = tabCom(i, 8)
    ActiveCell.Offset(0, 19).Value = tabCom(i, 9)
    ActiveCell.Offset(0, 20).Value = tabCom(i, 10)
    
    ActiveCell.Offset(1, 0).Select
    
    
Next i

End Sub



Sub supp_extraction()
'
' supp_données existantes colonne C, F a K, O et T & U
'

'
    Range("F2:K1500").Select
    Selection.ClearContents
    Range("C2:C1500").Select
    Selection.ClearContents
    Range("O2:O1500").Select
    Selection.ClearContents
    Range("T2: u1500").Select
    Selection.ClearContents
    Range("A2").Select
    
End Sub

Bebere · 25 Mars 2015

Re : Macro pour extraire plusieurs cellules d'un onglet

bonjour Vidou
à tester

Code:

Sub Extraction_commande()
    Dim derli As Long, l As Long, y As Long, derCol As Long, tabCom()

    Worksheets("COM").Activate
    derli = Cells.Find("*", [A1], , , 1, 2).Row
    derCol = Cells.Find("*", [A1], , , 2, 2).Column
    tbl = Range("A2571", Cells(derli, derCol))

    ' supprimer les données de 2KE_SDS
    Call supp_extraction

    For l = 1 To UBound(tbl, 1)
        If tbl(l, 1) = "COM" Then
            y = y + 1
            ReDim Preserve tabCom(1 To 10, 1 To y)    'les colonnes en ligne pour pouvoir ajouter des lignes
            tabCom(1, y) = tbl(l, 13)
            tabCom(2, y) = tbl(l, 3)
            tabCom(3, y) = tbl(l, 12)
            tabCom(4, y) = tbl(l, 4)
            tabCom(5, y) = tbl(l, 14)
            tabCom(6, y) = tbl(l, 1)
            tabCom(7, y) = tbl(l, 18)
            tabCom(8, y) = tbl(l, 11)
            tabCom(9, y) = tbl(l, 15)
            tabCom(10, y) = tbl(l, 6)
        End If
    Next l

    tabCom = Application.Transpose(tabCom)

    Worksheets("2KE_SDS").Activate
    l = 2
    For y = 1 To UBound(tabCom, 1)
        Range(l, 3) = tabCom(y, 1)
        Range(l, 6) = tabCom(y, 2)
        Range(l, 7) = tabCom(y, 3)
        Range(l, 8) = tabCom(y, 4)
        Range(l, 9) = tabCom(y, 5)
        Range(l, 10) = tabCom(y, 6)
        Range(l, 11) = tabCom(y, 7)
        Range(l, 15) = tabCom(y, 8)
        Range(l, 20) = tabCom(y, 9)
        Range(l, 21) = tabCom(y, 10)
        l = l + 1
    Next y

End Sub



Sub supp_extraction()
'
' supp_données existantes colonne C, F a K, O et T & U
'

    Worksheets("2KE_SDS").Activate
    Range("F2:K1500").ClearContents
    Range("C2:C1500").ClearContents
    Range("O2:O1500").ClearContents
    Range("T2: u1500").ClearContents
    Range("A2").Select

End Sub

Macro pour extraire plusieurs cellules d'un onglet

vidou

XLDnaute Junior

Bebere

XLDnaute Barbatruc

vidou

XLDnaute Junior

Bebere

XLDnaute Barbatruc

Discussions similaires