Copier d'un tableau à autre tableau sur une autre feuille avec VBA

Le 26/12/2022 à 00:37

Bonsoir.

- Je souhaite enregistrer les lignes qui ont "NEGATIF" ou "POSITIF" de la colonne 'ETAT' dans Le tableau CLOTURE qui se trouve dans la feuille HISTORQUE AVEC VBA

NB: enregistrer uniquement les trois premières colonnes

Cordialement...

33ms-bean1.xlsm (41.71 Ko)
Le 26/12/2022 à 04:55

Bonjour Linsonn,

Un tas de sujets traite de votre problématique, il suffit d'effectuer une petite recherche

Vous pouvez aussi cliquez sur le bouton ci-dessous "Rechercher des sujets similaires..."

A+

Le 27/12/2022 à 09:16

Bonjour BrunoM45,

Je suis un désolé je ne suis pas un pro j'ai jeté un coup d'œil un peu partout pour trouver quelque chose que je peux comprendre et modifier. je souhaite vraiment votre soutien Mr BrunoM45.

Le 27/12/2022 à 15:20

Re,

Permettez moi quand même de m'interroger, au CIC ils n'ont pas une DSI avec des gens capables de le faire

Je suis franchement surpris qu'on vous laisse mettre ce genre de fichier (même sans donnée personnelle) sur un forum

A+

Le 27/12/2022 à 16:16

Bonsoir Mr Bruno vous exagérez un peu.

Je cherche de l'aide. Pour un programme que je suis en train de mettre sur pied. Je ne travaille pas pour une entreprise sinon je ne viendrai dans ce forum pour demander de l'aide.

STP, STP si tu peux me proposer un code qui effectue un copier-coller sous condition entre deux tableaux ce sera un bon pour moi (même avec un fichier que tu peux toi-même me proposer à l'occasion.)

Le 27/12/2022 à 16:22

Re,

Désolé, je n'exagère pas... pensez simplement à la confidentialité des fichiers déposés

image

Ce n'est pas moi qui l'invente

Le 27/12/2022 à 17:14

C'est une erreur j'ai certainement modifié un fichier présent sur ma machine que j'ai récupéré en ligne ou sur ce forum pour monter mon exemple sinon cette identité ne me concerne pas directement. Mr Bruno M45.

Le 27/12/2022 à 17:45

En bref je développe un algorithme sur le trading haute fréquence. Pour cela j'ai besoin d'analyser les bases de données des produits financiers et gérer des ordres en cours jusqu’à ce quelle soit RENTABLES.

Je ne travaille pas pour une structure le besoin est personnelle. J'avais déjà bidouillé une macro sur cette tache mais elle prend trop de temps.

Le 27/12/2022 à 18:35

Bonjour LINSONN, Bruno

Avec le filtre :

Option Explicit
Sub Copy()
    Application.ScreenUpdating = False
    With Sheets("Feuil2").Cells(5, 3).CurrentRegion
        .Parent.AutoFilterMode = False
        .AutoFilter 3, Array("NEGATIF", "POSITIF"), 7
        With .Offset(1).Resize(, 3)
            .Copy Sheets("HISTORIQUE").Range("c" & Rows.Count).End(xlUp)(2)
        End With
        .AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Attention au nom de la feuille de destination.

klin89

Le 28/12/2022 à 00:34

Bonjour Klin89, BrunoM45

Bon boulot... Ça fait exactement ce que je souhaite.

Mais j'ai du mal à adapter ce code à ma feuille.

Si je peux me permettre d'en demander plus. MRS KLIN89

Si je souhaite qu'il copie de la colonne "CO" à la colonne "CY" de la "Feuil2" si dans la colonne BR contient "NEGATIF" ou "POSITIF" STP: sur cette feuille les données commencent à la ligne 35.

Ensuite

Qu’il colle le résultat à partir de la colonne "b" de la feuille "HISTORQUE" STP: sur cette feuille les données commencent à la ligne 9.

Comment modifier cela

Merci pour tous...

Cordialement.

Le 28/12/2022 à 11:12

Bonjour à tous,

Pourquoi ne pas joindre un fichier exemple représentatif de tes données ?

Cordialement,

Le 28/12/2022 à 12:28

Bonjour xorsankukai,

Merci pour le retour...

J'ai mis le tableau à jour.

OJECTIF: COPIER de 'CO' à 'CY' si BR = "POSITIF" ou "NEGATIF" du tableau47 Feuille (Feuil2)

et Coller de 'B' à 'L' Tableau4849 Feuille ( HISTORQUE)

Cordialement...

14ms-bean1.zip (313.16 Ko)
Le 28/12/2022 à 14:39

Re,

Un essai....

Sub copy()
 Dim tb, Newtb(), i&, k&, j, rcell As Range

  With Sheets("Feuil2")
   If Not .ListObjects(1).DataBodyRange Is Nothing Then
    tb = .ListObjects(1).DataBodyRange
    k = 0
     ReDim Newtb(0 To UBound(tb, 1), 1 To 35)
      For i = 1 To UBound(tb, 1)
       If tb(i, 59) Like "POSITIF" Or tb(i, 59) Like "NEGATIF" Then
        Newtb(k, 1) = tb(i, 1)
        For j = 82 To 92
         Newtb(k, j - 80) = tb(i, j): Next j
        k = k + 1
       End If
      Next i
   End If
  End With

   If k > 0 Then
    With Sheets("HISTORQUE").ListObjects(1)
     If .InsertRowRange Is Nothing Then
      Set rcell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
     Else
      Set rcell = .InsertRowRange.Cells(1)
     End If
    End With
     Application.DisplayAlerts = False
      rcell.Resize(k, 35).Value = Newtb
     Application.DisplayAlerts = True
     MsgBox "Données enregistrées", vbInformation
   Else
    MsgBox "Aucunes données à transférer", vbExclamation
   End If
  Erase tb: Erase Newtb: Set rcell = Nothing
End Sub

Cordialement,

Le 02/01/2023 à 22:55

Bonsoir Mr xorsankukai.

L'essai est impeccable.

Merci beaucoup.

Le 03/01/2023 à 07:35

Bonjour M xorsankukai.

J'ai du mal à modifier pour faire le schéma inverse

S'il te plait un dernier coup de main pour cette dernière partie

c’est-à-dire :

OJECTIF: si AB >= 1 COPIER de 'AJ' à 'AN' Coller de 'M' à 'Q' et

COPIER de 'AO' Coller de 'V' et COPIER de 'AP' Coller de 'AP'

La copie se fait entre le tableau4849 Feuille (HISTORQUE) et le Tableau47 Feuille ( Feuil2)

Cordialement...

J'ai commencé à modifier le code ci-dessous mais je suis resté là je ne comprends pas la suite de la macro.

J’ai joint le fichier à jour.

Sub copyyy()
 Dim tb, Newtb(), i&, k&, j, rcell As Range

  With Sheets("HISTORQUE")
   If Not .ListObjects(1).DataBodyRange Is Nothing Then
    tb = .ListObjects(1).DataBodyRange
    k = 0
     ReDim Newtb(0 To UBound(tb, 1), 1 To 8)
      For i = 1 To UBound(tb, 1)
       If tb(i, 42) Like "NEGATIF" Then
        Newtb(k, 1) = tb(i, 1)
        For j = 36 To 43

         Newtb(k, j - 80) = tb(i, j): Next j

        k = k + 1

       End If
      Next i
   End If
  End With

   If k > 0 Then
    With Sheets("Feuil2").ListObjects(1)
     If .InsertRowRange Is Nothing Then
      Set rcell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
     Else
      Set rcell = .InsertRowRange.Cells(1)
     End If
    End With
     Application.DisplayAlerts = False
      rcell.Resize(k, 35).Value = Newtb
     Application.DisplayAlerts = True
     Mégot "Données enregistrées", vbInformation
   Else
    MsgBox "Aucunes données à transférer", vbExclamation
   End If
  Erase tb: Erase Newtb: Set rcell = Nothing
End Sub
13ms-bean1.xlsm (287.76 Ko)
Le 03/01/2023 à 09:29

Bonjour LINSONN, le forum,

Un nouvel essai....mais j'ai du mal à m'y retrouver....

Sub copyyy()
 Dim tb, Newtb(), i&, k&, j, rcell As Range

  With Sheets("HISTORQUE")
   If Not .ListObjects(1).DataBodyRange Is Nothing Then
    tb = .ListObjects(1).DataBodyRange
    k = 0
     ReDim Newtb(0 To UBound(tb, 1), 1 To 31)
      For i = 1 To UBound(tb, 1)
       If tb(i, 28) <> "" And tb(i, 28) >= 1 Then
        Newtb(k, 1) = tb(i, 1) 'indice
        For j = 36 To 40
         Newtb(k, j - 34) = tb(i, j): Next j  'AJ:AN==> M:Q
         Newtb(k, 11) = tb(i, 41) ' AO==> V
         Newtb(k, 31) = tb(i, 42) ' AP==> AP
        k = k + 1
       End If
      Next i
   End If
  End With

   If k > 0 Then
    With Sheets("Feuil2").ListObjects(1)
     If .InsertRowRange Is Nothing Then
      Set rcell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
     Else
      Set rcell = .InsertRowRange.Cells(1)
     End If
    End With
     Application.DisplayAlerts = False
      rcell.Resize(k, 31).Value = Newtb
     Application.DisplayAlerts = True
     MsgBox "Données enregistrées", vbInformation
   Else
    MsgBox "Aucunes données à transférer", vbExclamation
   End If
  Erase tb: Erase Newtb: Set rcell = Nothing
End Sub

Cordialement,

Le 03/01/2023 à 10:56

Le code est sublime...

il réagit parfaitement.

En fin je souhaite supprimer les lignes "POSITIFS" et "NEGATIFS" à la fin de la macro 'copy' est ce que c'est possible ?

Le 03/01/2023 à 11:16

Re,

Cool,

En fin je souhaite supprimer les lignes "POSITIFS" et "NEGATIFS" à la fin de la macro 'copy' est ce que c'est possible ?

Si tu parles de cette macro :

On ne copie que les lignes qui contiennent "POSITIF" où "NEGATIF" dans la colonne BR de la Feuil2....

  • tu souhaites faire l'inverse ? Copier uniquement les lignes qui ne contiennent pas... ?
  • où ne pas copier mais supprimer ces lignes ?

Cordialement,

Le 03/01/2023 à 11:33

Oui la première macro

après la copie supprimer.

Le 03/01/2023 à 14:26

Re,

  • On copie les données dans la feuille HISTORQUE
  • On supprime les données copiées de la Feuil2

A tester:

Sub copyy()
 Dim tb, Newtb(), i&, k&, j, rcell As Range

 Application.ScreenUpdating = False

  With Sheets("Feuil2")
   If Not .ListObjects(1).DataBodyRange Is Nothing Then
    tb = .ListObjects(1).DataBodyRange
    k = 0
     ReDim Newtb(0 To UBound(tb, 1), 1 To 12)
      For i = 1 To UBound(tb, 1)
       If tb(i, 59) Like "POSITIF" Or tb(i, 59) Like "NEGATIF" Then
        Newtb(k, 1) = tb(i, 1)
        For j = 82 To 92
         Newtb(k, j - 80) = tb(i, j): Next j
        k = k + 1
       End If
      Next i

      With .ListObjects(1)
       If .ShowAutoFilter Then .AutoFilter.ShowAllData
       .Range.AutoFilter Field:=59, Criteria1:="=NEGATIF", Operator:=xlOr, Criteria2:="=POSITIF"
        On Error Resume Next
         Application.DisplayAlerts = False
         .DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
        On Error GoTo 0
         Application.DisplayAlerts = True
       If .ShowAutoFilter Then .AutoFilter.ShowAllData
      End With

      If k > 0 Then
       With Sheets("HISTORQUE").ListObjects(1)
        If .InsertRowRange Is Nothing Then
         Set rcell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
        Else
         Set rcell = .InsertRowRange.Cells(1)
        End If
       End With
       Application.DisplayAlerts = False
        rcell.Resize(k, 12).Value = Newtb
       Application.DisplayAlerts = True
       MsgBox "Données enregistrées", vbInformation
      Else
       MsgBox "Aucunes données à transférer", vbExclamation
      End If
  End If
 End With
 Erase tb: Erase Newtb: Set rcell = Nothing
End Sub

Il y a certainement moyen de simplifier........

Cordialement,

Rechercher des sujets similaires à "copier tableau feuille vba"