Coller un tableau

[CISCO]

Bonsoir

Sur une feuille j'ai une plage de données, par exemple en B4:C10, avec une ligne sur deux vides. J'aimerai copier cette plage dans un tableau et ne recoller ailleurs que les lignes contenant des données à partir de E4, exactement dans le même ordre.

Pour le moment, j'ai écrit ça :

Sub transfert()
Dim tablo(), tablo2()

tablo = Range("B4:C10").Value
tablo2 = Range("E4:F7").Value

        For col = 1 To 2
                For i = 1 To UBound(tablo) Step 2
                lig = Int(i / 2) + 1
                tablo2(lig, col) = tablo(i, col)
                Next i
         Next col

Range("E4").Select
.......

End Sub

Bien sûr, il manque des lignes.
On pourrait obtenir le résultat désiré en mettant une ligne de code du style Range(...,...) = tablo (i, col) à la place de tablo2 (lig, col) = tablo (i, col).
Je pourrais aussi coller ces valeurs avec deux boucles à la place des pointillés, mais j'aimerai savoir s'il est possible de coller le tablo2 en une seule fois, sans utiliser une ou des boucles, histoire de gagner en rapidité.

@ plus

P.S : Dans la réalité, les plages initiales contiennent une soixantaine de lignes, et il faut faire cela à partir de 120 feuilles.

 

[Staple1600]

Re

@CISCO
Désolé 😉
Mon œil s'était focalisé sur cette seule ligne 😉

Je suppose que c'est -4175+12 = -4163 et -4175+12+1 = -4162.

(je n'avais pas vu la ligne au dessus 😉

 

[Si...]

Bon_jour

voir Si cela correspond ...

 

[job75]

Bonsoir à tous, salut Si...,

Puisque CISCO veut éviter les boucles :

Sub Copie()
With [B4:C10] 'tableau source
    .Copy
    .Offset(1000).Insert xlDown 'décalage à adapter
    With .Offset(1000)
        .UnMerge 'défusionne
        Intersect(.SpecialCells(xlCellTypeConstants).EntireRow, .Cells).Copy
        [E4].PasteSpecial xlPasteValues
        .Delete xlUp
    End With
    With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
End Sub

Je laisse CISCO voir la mise en forme (bordures etc)

A+

 

[job75]

Re,

Avec ceci pas besoin de collage spécial et la mise en forme est copiée :

Sub Copie()
With [B4:C10] 'tableau source
    .Copy
    .Offset(1000).Insert xlDown 'décalage à adapter
    With .Offset(1000)
        .UnMerge 'défusionne
        Intersect(.SpecialCells(xlCellTypeConstants).EntireRow, .Cells).Copy [E4]
        .Delete xlUp
    End With
    With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
End Sub

Fichier joint.

A+

 

[CISCO]

Bonjour à tous, bonjour Si et Job75.

@ Si : Merci. Apparemment, tu jongles avec deux tableaux, t et ti.

@ Job75 : Merci. C'est nickel. Cela fait tout à fait ce que je voulais.

Je vais essayer de comprendre davantage comment cela fonctionne. F8, F8, F8...

Au plaisir

@ plus

 

[job75]

Bonjour CISCO, le forum,

Une solution plus élaborée dans ce fichier (2) :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range
Application.ScreenUpdating = False
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
Range("E4:F" & Rows.Count).Clear 'RAZ
With [B4:C10] 'tableau source
    If Application.CountIf(.Cells, "?*") Then
        Set P = .Offset(UsedRange.Row + UsedRange.Rows.Count - .Row) 'décalage hors du UsedRange
        .Copy P
        P.UnMerge 'défusionne
        Intersect(P.SpecialCells(xlCellTypeConstants).EntireRow, P).Copy [E4]
        P.Delete xlUp
    End If
End With
With UsedRange: End With 'actualise les barres de défilement
Application.EnableEvents = True 'réactive les évènements
End Sub

Bonne journée.

 

[job75]

Re,

Il faut savoir que le copier-coller d'un nombre important de plages disjointes a ses limites.

Voyez ce que donne le fichier joint avec un tableau source de seulement 2000 lignes (1000 plages disjointes).

Chez moi la macro s'exécute en 55 secondes, c'est la limite de l'acceptable.

Conclusion : sur un grand tableau il faut travailler avec des tableaux VBA.

A+

 

[CISCO]

Bonjour à tous

Merci Job75 pour ces précisions. Chez moi, l'exemple que tu as donné tourne en 11 s. C'est tout à fait acceptable. Je vais essayer d'adapter cela sur un fichier plus lourd que la pièce jointe que j'avais mis en exemple. Je te dirais ce que cela donne, si j'y arrive. Pour ce qui est de l'utilisation des tableaux VBA, c'était mon idée initiale...

@ plus

 

[CISCO]

Bonjour à tous

@ Job75 : Je viens d'adapter ta dernière proposition à mon fichier réel, et cela tourne vraiment très vite, disons deux ou trois secondes contre une quinzaine avec une boucle. Merci pour cette méthode.

Malheureusement, cela ne fait pas exactement ce dont j'ai besoin, à savoir que cela supprime trop de lignes. Cf. un autre exemple en pièce jointe pour mieux comprendre mon besoin. En réalité, l'objectif n'est pas de supprimer les lignes vides, mais uniquement celles du bas des cellules fusionnées, toutes les lignes impaires dans l'exemple ci-joint. Comme déjà dit, je sais le faire tout simplement avec une boucle avec un step 2, mais j'aimerai bien trouver une méthode plus rapide. Peut-être avec autre chose que xlCellTypeConstants dans Intersect(P.SpecialCells(xlCellTypeConstants).EntireRow, P).Copy [E4]. Je vais, de ce pas, chercher...

@ plus

 

[mapomme]

Bonsoir @CISCO, @job75

Un autre essai...

 

[CISCO]

Bonsoir

Merci mapomme. Il y a deux boucles, mais qu'est-ce que cela va vite !!

J'essaye d'adapter ça à mon fichier réel.

@ plus

 

[job75]

Bonjour CISCO, mapomme,

Private Sub Worksheet_Change(ByVal Target As Range)
Dim P As Range, ncol%, tablo, resu(), i&, n&, j%
Application.EnableEvents = False 'désactive les évènements
If FilterMode Then ShowAllData 'si la feuille est filtrée
Set P = [B4:C14] 'tableau source, à adapter
ncol = P.Columns.Count
tablo = P.Value
ReDim resu(1 To UBound(tablo), 1 To ncol)
For i = 1 To P.Rows.Count
    n = n + 1
    For j = 1 To ncol
        resu(n, j) = tablo(i, j)
    Next j
    i = i + P(i, 1).MergeArea.Rows.Count - 1
Next i
With [E4] '1ère cellule des résultats, à adapter
    .Resize(n, ncol) = resu
    .Resize(n, ncol).Borders.Weight = xlThin
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol).Delete xlUp 'RAZ sous le tableau
End With
Application.EnableEvents = True 'réactive les évènements
End Sub

Fonctionne quel que soit le nombre de cellules fusionnées sur chaque ligne du tableau source.

Bien sûr ici les formats ne sont pas copiés.

Fichier joint.

A+

 

[job75]

Bonjour CISCO, mapomme, le forum,

Testé avec un tableau source de 60 000 lignes (B4:C60003) :

- macro post #25 => 0,9 seconde

- macro post #27 => 1,3 seconde, normal car elle est plus générale.

Bonne journée.

 

[mapomme]

Bonjour à tous,

A 0,4 sec. près, vaut mieux prendre celle qui est plus générale... (moi personnellement, je fais très peu de choses en moins d'une demi-seconde 😀)

 

[CISCO]

Bonjour à tous

Remerci Job75. Ne me reste plus qu'à tester tout cela sur mon vrai fichier, histoire de comprendre la logique de ta macro, et pour voir si c'est plus rapide.

Au plaisir.