Autres Copier des données vers une nouvelle feuille excel VBA

fanfan38 à dit:

Bonjour et bienvenu sur le forum
Un fichier est TOUJOURS le bienvenu
Pour mettre du code cliquer d'abord sur </> dans le menu
Pourquoi nommer des feuilles si c'est pas pour utiliser ces noms?
Je pense qu'une boucle serait nécessaire

VB:

Sub LACEY()

Dim Source As Worksheet
Dim target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Shipping List")
Set Tarket = ActiveWorkbook.Worksheets("LACEY")

' Only if they have a number in the cell
If somme(Source.Range("N12:N1519")) > 0 Then
else
' Only need lacey active, DO NOT COPY if cell indicate "N/A"
If Source.Cells("E12:E1519") = ("CAP" Or "USA" Or "SPF" Or "LAM" Or LVL) Then
'Range.Copy Shipping list to Lacey
Source.Range("H12:H1519").Copy Worksheets("LACEY").Range("C16")
Source.Range("I12:I1519").Copy Tarket.Range("D16")
Source.Range("E12:E1519").Copy Tarket.Range("B16")
'Multiply Source.Range("I12:I1519") by Source.Range("N12:N1519")
End If
End Sub

A+ François

Cliquez pour agrandir...

AtTheOne à dit:

Bonsoir à toutes & à tous, bonsoir @Carolinebd, bonsoir @fanfan38
Bon j'ai interprété le pseudo code que tu nous as fourni. Comme le dit @fanfan38 je crois qu'il s'agit de faire une boucle sur toutes les cellules de la plage source.
' Only if they have a number in the cell :
On teste si la cellule de la plage en colonne "N" est numérique et supérieur à 0 (avec la fonction excel ISNUMBER pour écarter le cellules vides
'Also :
Moi j'interprète le "also" comme une condition supplémentaire :
On teste si la cellule correspondante de la colonne "E" est égale à une des valeurs "CAP", "USA", "SPF", "LAM", "LVL"
Si c'est le cas on procède à la copie, sinon on ne fait rien la cible commence en "B16 : D16" et se décale vers le bas progressivement.

MAIS TOUT ÇA CE NE SONT QUE DES SUPPOSITIONS !

Voilà le code que je propose :

VB:

Sub CopierSousConditions()

     Dim Source As Worksheet, Cible As Worksheet, Rg As Range, i%
     Set Source = ActiveWorkbook.Worksheets("Shipping List")
     Set Cible = ActiveWorkbook.Worksheets("LACEY")
     Set RgCible = Cible.Range("B16")
     RgCible.Resize(1508, 3).Clear
 
     Application.ScreenUpdating = False
     i = 0
     For Each C In Source.Range("N12:N1519").Cells
          If WorksheetFunction.IsNumber(C) Then
               If C.Value > 0 Then
                    Select Case C.Offset(0, -9).Value
                         Case "CAP", "USA", "SPF", "LAM", "LVL"
                              C.Offset(0, -9).Copy Destination:=RgCible.Offset(i, 0)
                              C.Offset(0, -6).Copy Destination:=RgCible.Offset(i, 1)
                              C.Offset(0, -5).Copy Destination:=RgCible.Offset(i, 2)
                              i = i + 1
                         Case Else
                              'Rien
                    End Select
               End If
          End If
     Next
     Application.Goto RgCible
     Application.ScreenUpdating = False
 
End Sub

Remarque : On peut nettement accélérer l'exécution s'il ne faut pas copier les formats et qu'on ne s’intéresse qu'au valeurs, à toi de dire

Voir le fichier joint en PJ

Cliquez pour agrandir...

Carolinebd à dit:

Bonjour,

Oui j'ai tenté de faire comme je peux avec ce que je connaissait je ne connaissais pas les boucles mais je vais m'en informer.
Effectivement, le If est des conditions supplémentaire pour dire si la copie se fait ou non.
Le format n'est pas obligatoire mais ce n'est pas grave non plus.

Je vais étudier votre code pour le comprendre pour une prochaine fois ou si j'ai des choses à lui ajouter
un énorme merci.

Cliquez pour agrandir...

AtTheOne à dit:

Bonjour à toutes & à tous, bonjour @Carolinebd
Je t'ai mis en pièce jointe une version avec des codes commentés qui prennent en compte ta nouvelle demande (mettre des 1 en colonne A).

Il y a 2 versions de la macro :

• Une qui recopie les cellules avec leur format
• Une qui ne transfère que les valeurs

Tu verras le temps d'exécution de la 2ième n'a rien à voir avec celui de la 1ère.


Et bien il sert à changer la ligne ou l'on copie les données (à chaque fois que l'on copie une ligne on incrémente i pour, la fois suivante, écrire sur la ligne du dessous.)

À bientôt

Cliquez pour agrandir...

Rgcible.Resize(i, 5).Value2 = Application.Transpose(Résultats)

'On attribue à la plage cible redimensionnée les résultats
'(on utilise la fonction TRANSPOSE pour passer le tableau en lignes, colonnes)
Rgcible.Resize(i, 5).Value2 = Application.Transpose(Résultats)

Application.Goto Rgcible.Offset(-1, 0), True
Application.ScreenUpdating = False

Cliquez pour agrandir...

"Set RgSource = Source.Range("E12:AB2019") 'Plage contenant toutes les données"

AtTheOne à dit:

Bonsoir @Carolinebd et bonsoir à toutes & à tous !

Peux-tu joindre un exemple de ton travail ou au moins le texte complet de ta macro ? Cela nous faciliterait la tâche !

Le tableau "Résultats" doit être trop important pour la fonction TRANSPOSE, dans ce cas il faut faire une transposition par code.

L'idée est que comme tu connais les dimensions du tableau "Résultats"
(respectivement UBound(Résultats,1) et UBound(résultats,2)),
tu vas transposer son contenu dans un nouveau tableau en inversant lignes et colonnes :

VB:

...
NbL=UBound(Résultats,2)
NbC=Ubound(Résultats,1)
ReDim NouveauRés(1 to NbL, 1 to NbC)
For i = 1 to NbL
    For j = 1 to NbC
        NouveauRés(i,j)=Résultats(j,i)
    Next j
Next i
Rgcible.Resize(NbL, NbC).Value2 = NouveauRés
...

J'écris directement dans l'éditeur de Excel Downloads sans pouvoir tester dans EXCEL, mais cela devrait fonctionner.

À bientôt

Cliquez pour agrandir...

Sub LOAD3()

Dim Source As Worksheet, Cible As Worksheet, RgSource As Range, Rgcible As Range, i%
Dim Données(), Résultats()

Set Source = ActiveWorkbook.Worksheets("Shipping List")
Set Cible = ActiveWorkbook.Worksheets("LACEY")

Set RgSource = Source.Range("E12:AB2019") 'Plage contenant toutes les données
Set Rgcible = Cible.Range("N23") '1ère cellule de la plage cible

'On nettoie la cible (valeurs et formats)
Rgcible.Resize(2008, 5).Clear

Application.ScreenUpdating = False

'on stocke dans un tableau de variables toutes les valeurs de la plage de données
Données = RgSource.Value2

'i : Index pour de décalage en ligne de la plage cible
i = 0

For j = 1 To UBound(Données, 1) 'J varie de 1 aux nombre de lignes de la plage des données (ici 2008 lignes)

If IsNumeric(Données(j, 20)) And Not IsEmpty(Données(j, 20)) Then
If Données(j, 20) > 0 Then
'Ici Données(j,20) est une valeur numérique supérieure à 0

Select Case Données(j, 1)
Case "CAP", "USA", "SPF", "LAM", "LVL", "PLY"
'On incrémente i pour le prochain résultat
i = i + 1
'on redimentionne le tableau Résultats et on le remplit (au début i vaut 1)
'remarque le tableau est en colonnes, lignes et non pas en lignes, colonnes
ReDim Preserve Résultats(1 To 5, 1 To i)
Résultats(1, i) = 3
Résultats(2, i) = Données(j, 1)
Résultats(3, i) = Données(j, 4)
Résultats(4, i) = Données(j, 24)
Résultats(5, i) = Données(j, 20)

Case Else
'Rien
End Select
End If
End If
Next

'On attribue à la plage cible redimensionnée les résultats
'(on utilise la fonction TRANSPOSE pour passer le tableau en lignes, colonnes)
Rgcible.Resize(i, 5).Value2 = Application.Transpose(Résultats)

Application.Goto Rgcible.Offset(-1, 0), True
Application.ScreenUpdating = False

End Sub

Cliquez pour agrandir...