Coup de pouce sur une macro

Le 01/06/2021 à 15:42

Bonjour

Déjà je remercie la personne qui m'a aidé pour mon début de macro, que j'ai voulu améliorer : sachant que mes données rapatriées doivent commencer à la ligne 21.Jusque là tout va bien mais quand j'importe des lignes vierges se créent (7) comment je dois procéder pour que celles-ci n'apparaissent pas ?

Mille mercis par avance

Option Explicit
Sub Ajout()

 Dim x%, k%, i%
 Dim colsource, coldest, tablo, tabloR()
 Dim tab_hypretraite() As Double

          tablo = Sheets("BDD").ListObjects("tb_BDD").DataBodyRange
      colsource = Array(1, 2, 3, 4, 5, 6, 7, 8)
        coldest = Array(1, 2, 3, 6, 7, 9, 12, 13)

   With Sheets("Suivi")
    If .ListObjects("tb_suivi").DataBodyRange Is Nothing Then .ListObjects("tb_suivi").DataBodyRange
     k = 0
      For i = 1 To UBound(tablo, 1)
       If tablo(i, 9) Like "x" Then
        ReDim Preserve tabloR(1 To 15, 1 To k + 1)
         For x = LBound(colsource) To UBound(colsource)
          tabloR(coldest(x), 1 + k) = tablo(i, colsource(x))

  Sheets("Suivi").Activate
  Range("b21").Select
  Selection.EntireRow.Insert
.PasteSpecial xlPasteValues
         Next x
     k = 1 + k
       End If
      Next i
     On Error Resume Next
      .Cells([tb_suivi].Rows.Count + 21, 1).End(xlUp).Offset(21, 1).Resize(UBound(tabloR, 2), 15) = Application.Transpose(tabloR)
  tab_hypretraite(i + 1, k + 1) = .Cells(i, k).Value
   Range("B21").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
   MsgBox "Transfert effectué sur feuille Suivi"
   Sheets("Suivi").Activate
End Sub
Le 01/06/2021 à 18:49

Bonsoir paita, le forum,

Si tu souhaites conserver les données existantes dans le tableau de suivi, et inscrire les données les unes à la suite des autres:

Option Explicit
Sub Ajout()

 Dim x%, k%, i%, dl%
 Dim colsource, coldest, tablo, tabloR()
 Dim tab_hypretraite() As Double

          tablo = Sheets("BDD").ListObjects("tb_BDD").DataBodyRange
      colsource = Array(1, 2, 3, 4, 5, 6, 7, 8)
        coldest = Array(1, 2, 3, 6, 7, 9, 12, 13)

   With Sheets("Suivi")
     k = 0
      For i = 1 To UBound(tablo, 1)
       If tablo(i, 9) Like "x" Then
        ReDim Preserve tabloR(1 To 15, 1 To k + 1)
         For x = LBound(colsource) To UBound(colsource)
          tabloR(coldest(x), 1 + k) = tablo(i, colsource(x))
         Next x
     k = 1 + k
       End If
      Next i
     On Error Resume Next
       dl = [tb_suivi].Rows.Count + [tb_suivi].Rows(0).Row
      .Cells(dl, 2).Resize(UBound(tabloR, 2), 15) = Application.Transpose(tabloR): .ListObjects("tb_suivi").ListRows.Add
    End With
   MsgBox "Transfert effectué sur feuille Suivi"
   Sheets("Suivi").Activate
End Sub
11maj-base.xlsm (29.83 Ko)

En revanche, je ne suis pas parvenu à inscrire les données par la haut...

Cordialement,

Le 02/06/2021 à 09:18

Bonjour xorsankukai

Avec ton aide j'ai pu arriver et pour coller les données par le haut, j'ai pu y arriver, je te mets la manip que j'ai faite et qui fonctionne

Option Explicit
Sub Ajout()

 Dim x%, k%, i%, dl%
 Dim colsource, coldest, tablo, tabloR()
 Dim tab_hypretraite() As Double

          tablo = Sheets("BDD").ListObjects("tb_BDD").DataBodyRange
      colsource = Array(1, 2, 3, 4, 5, 6, 7, 8)
        coldest = Array(1, 2, 3, 6, 7, 9, 12, 13)

   With Sheets("Suivi")
     k = 0
      For i = 1 To UBound(tablo, 1)
       If tablo(i, 9) Like "x" Then
        ReDim Preserve tabloR(1 To 15, 1 To k + 1)
         For x = LBound(colsource) To UBound(colsource)
          tabloR(coldest(x), 1 + k) = tablo(i, colsource(x))
         Next x
     Sheets("Suivi").Activate
  Range("b21").Select
  Selection.EntireRow.insert
     k = 1 + k
       End If
      Next i
     On Error Resume Next
       dl = [tb_suivi].Rows.Count + [tb_suivi].Rows(0).Row
      .Cells([tb_suivi].Rows.Count + 21, 1).End(xlUp).Offset(21, 1).Resize(UBound(tabloR, 2), 15) = Application.Transpose(tabloR): .ListObjects("tb_suivi").ListRows.Add
    End With
   MsgBox "Transfert effectué sur feuille Suivi"
   Sheets("Suivi").Activate
End Sub

Encore mille mercis pour ton aide et une bonne journée

Le 02/06/2021 à 10:29

Bonjour paita, le forum,

Ravi d'avoir pu t'aider et merci pour la soluce pour l'inscription par le haut

J'ai essayé d'optimiser le code:

  • inutile d'activer la feuille "Suivi" puisque j'utilise With sheets("Suivi").
  • De même pour B1, on peut éviter le .select.
  • J'ai supprimer l'ajout de ligne en fin de tableau puisqu'on écrit par le haut.
Option Explicit
Sub Ajout()

 Dim x%, k%, i%
 Dim colsource, coldest, tablo, tabloR()

          tablo = Sheets("BDD").ListObjects("tb_BDD").DataBodyRange
      colsource = Array(1, 2, 3, 4, 5, 6, 7, 8)
        coldest = Array(1, 2, 3, 6, 7, 9, 12, 13)

  ' Application.ScreenUpdating = False '...............évite le scintillement de l'écran

   With Sheets("Suivi")
     k = 0
      For i = 1 To UBound(tablo, 1)
       If tablo(i, 9) Like "x" Then
        ReDim Preserve tabloR(1 To 15, 1 To k + 1)
         For x = LBound(colsource) To UBound(colsource)
          tabloR(coldest(x), 1 + k) = tablo(i, colsource(x))
         Next x
         .ListObjects("tb_suivi").ListRows.Add 1 '....ajoute une ligne en début de tableau (sans le 1, c'est en fin)
     k = 1 + k
       End If
      Next i
     On Error Resume Next
    .Cells([tb_suivi].Rows.Count + 21, 1).End(xlUp).Offset(21, 1).Resize(UBound(tabloR, 2), 15) = Application.Transpose(tabloR) 
   End With
   MsgBox "Transfert effectué sur feuille Suivi"
   Sheets("Suivi").Activate
End Sub

Chez moi, il y a un petit gain de temps,

8maj-base.xlsm (33.97 Ko)

Bonne continuation,

A bientôt,

Le 02/06/2021 à 10:33

Merci pour cette simplification et en effet, c'est un turbo, ravie d'avoir fait ta connaissance et encore merci pour ton aide précieuse

Rechercher des sujets similaires à "coup pouce macro"