XL 2013 COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

[Regueiro]

Bonsoir le Forum.
J'aimerais transposé les données de mon tablo sur une autre feuille.
Avec un pas de 5 lignes ??
Merci de votre Aide
@+

Option Explicit
Public Derlig As Long, DerCol As Long
Public Cell As Range
Sub Transfert()
'Transfert des données de la Feuille Calculation 1
Dim Dico As Object
Dim F As Worksheet
Set F = Worksheets("CALCULATION 1")
MsgBox F.Name
Set Dico = CreateObject("Scripting.Dictionary")

    Derlig = F.Cells(Rows.Count, 5).End(xlUp).Row
    MsgBox Derlig
        For Each Cell In F.Range("E18", F.Cells(Derlig, 5))
            If Cell <> "" Then Dico(Cell.Value) = ""
        Next Cell

With Sheets("ESSAI")
[E20].Resize(Dico.Count) = Application.Transpose(Dico.keys)

End With

End Sub

 

[BOISGONTIER]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

Bonjour,

Sub Transfert()
'Transfert des données de la Feuille Calculation 1
Dim Dico As Object, i, derlig
Dim f As Worksheet
Set f = Worksheets("calculation 1")
Set Dico = CreateObject("Scripting.Dictionary")
derlig = f.Cells(Rows.Count, 5).End(xlUp).Row
For i = 18 To derlig Step 5
   If f.Cells(i, 5) <> "" Then Dico(f.Cells(i, 5).Value) = ""
Next i
With Sheets("essai")
.[e20].Resize(Dico.Count) = Application.Transpose(Dico.keys)
End With
End Sub

ou

Sub essai()
  Dim rng, b(), f, derlig
  Set f = Worksheets("calculation 1")
  derlig = f.Cells(Rows.Count, 5).End(xlUp).Row
  Set rng = f.Range("e18:e" & derlig)
  b = Application.Index(rng, Evaluate("Row(1:" & (rng.Rows.Count + 1) \ 5 & ")*5-5+1"), 1)
  Sheets("essai").[e20].Resize(UBound(b), UBound(b, 2)) = b
End Sub

JB

 

[Paf]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

Bonjour Regueiro, BOISGONTIER,

Interprétation différente : le pas de 5 est appliqué à la copie ( ??)

Sub Transfert1()
 'Transfert des données avec tableaux

 Dim TabIni, TabFin(), F As Worksheet, derlig As Long
 Set F = Worksheets("calculation 1")
 derlig = F.Cells(Rows.Count, 5).End(xlUp).Row
 TabIni = F.Range("e18:e" & derlig)
 For i = LBound(TabIni) To UBound(TabIni)
    x = x + 1
    ReDim Preserve TabFin(1 To x + 3)
    TabFin(x) = TabIni(i, 1)
    For x = x + 1 To x + 3
        TabFin(x) = ""
    Next x
 Next i
 Worksheets("essai").[E20].Resize(UBound(TabFin), 1) = Application.Transpose(TabFin)
End Sub

ou

Sub Transfert2()
 'Transfert des données sans tableau ni dico
 Dim F As Worksheet, derlig As Long
 Set F = Worksheets("CALCULATION 1")

 derlig = F.Cells(Rows.Count, 5).End(xlUp).Row
 i = 20
 With Worksheets("ESSAI")
 For Each Cell In F.Range("E18", F.Cells(derlig, 5))
    If Cell <> "" Then
        .Cells(i, 5) = Cell
        i = i + 5
    End If
 Next Cell
 End With
End Sub

A+

 

[BOISGONTIER]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

Bonjour,

Si le dictionnaire sert à éliminer les doublons

Sub Transfert()
  'Transfert des données de la Feuille Calculation 1
  Dim Dico As Object, i, derlig, cell, c
  Dim f As Worksheet
  Set f = Worksheets("calculation 1")
  Set Dico = CreateObject("Scripting.Dictionary")
  derlig = f.Cells(Rows.Count, "e").End(xlUp).Row
  For Each cell In f.Range("E18", f.Cells(derlig, "e"))
    If cell <> "" Then Dico(cell.Value) = ""
  Next cell
  i = 20
  With Sheets("essai")
    For Each c In Dico.keys
     .Cells(i, "e") = c
      i = i + 5
    Next c
  End With
End Sub

JB

 

[Regueiro]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

Bonsoir le Forum, Paf, Boisgontier
Tout d'abord merci pour votre Aide, car je ne suis pas très à l'aise avec ces TABLEAUX
Boisgontier effectivement je n'ai pas besoin du dico car je ne veux pas supprimer les doublons
Par contre dans la colonne il y a des cellules vides et mon tableau comporte 4 colonnes,
mais je n'arrive pas alimenter mon tableau sans les vides :

For Each Cell In F.Range("E18", F.Cells(Derlig, 5))
If Cell <> "" Then Tablo(1) = Cell.Value
Next Cell

With Sheets("ESSAI")
b = 20
For Each d In Tablo(1)
Range("E" & b) = d
b = b + 5
Next d

Merci pour votre Aide
@+

 

[Si...]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

salut

et avec un tableau sur la feuille ?

'copie quand Feuil2 est activée
Private Sub Worksheet_Activate()
  Dim L As Long, C As Range
  L = 20
  [E:H].Delete
  For Each C In [T[Col1]]
    C.Resize(1, 4).Copy Cells(L, "E")
    L = L + 5
  Next
End Sub

 

[Regueiro]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

Bonsoir,
Merci Si, mais je ne peux malheureusement pas de Tableau sur cette feuille
Car il y a plein de formule différentes

Le Code de PAF est très performant 0.15 secondes
Je ne sais pas si le tableau est plus rapide ??

Sub Transfert2()
 'Transfert des données sans tableau ni dico
Dim F As Worksheet, derlig As Long
Dim i
 'Dim start As Single
Dim start As Double
start = Timer
 
 Set F = Worksheets("CALCULATION 1")

 derlig = F.Cells(Rows.Count, 5).End(xlUp).Row
 i = 20
 With Worksheets("ESSAI")
 For Each Cell In F.Range("E18", F.Cells(derlig, 5))
    If Cell <> "" Then
        .Cells(i, 5) = Cell
        .Cells(i, 7) = Cell.Offset(, 1)
        .Cells(i, 9) = Cell.Offset(, 3)
        .Cells(i, 10) = Cell.Offset(, 4)

        i = i + 5
    End If
 Next Cell
 End With
 MsgBox "durée du traitement: " & Timer - start & " secondes"
End Sub

@+

 

[Paf]

Re : COPIER UN TABLO DICTIONARY AVEC 1 Pas DE 5 LIGNES

Re tous, et bonjour Si... ,


Sans classeur support , ni indications précises, peut-être:

Sub Transfert1()
 'Transfert des données avec tableaux

 Dim TabIni, TabFin(), F As Worksheet, derlig As Long
 Set F = Worksheets("calculation 1")
 derlig = F.Cells(Rows.Count, 5).End(xlUp).Row
 TabIni = F.Range("E18:I" & derlig)
 For i = LBound(TabIni) To UBound(TabIni)
    If TabIni(i, 1) <> "" Then
        x = x + 4
        ReDim Preserve TabFin(1 To 6, 1 To x)
        TabFin(1, x - 3) = TabIni(i, 1)
        TabFin(3, x - 3) = TabIni(i, 2)
        TabFin(5, x - 3) = TabIni(i, 4)
        TabFin(6, x - 3) = TabIni(i, 5)
    End If
 Next i
 Worksheets("essai").[E20].Resize(UBound(TabFin, 2), UBound(TabFin, 1)) = Application.Transpose(TabFin)
End Sub

A+