Réorganiser un Onglet

Bonjour le forum,

Je viens sollicité votre aide sur le sujet suivant

Dans un fichier rempli de de Datas de A1:PU18322

je souhaiterai faire 4 actions dans un nouveau Onglet

  • Dupliquer l'onglet SLA
  • Replacer la Date ligne par ligne
  • Copier une celule sur sa gauche
  • Effacer les anciennes lignes #######Date

Par avance Merci pour votre aide

Bien cordialement

9transpose.xlsb (230.30 Ko)

Bonjour,

Voilà ma proposition (en macro) :

Sub RemanierData()

Dim LigMax As Long, Lig As Long, DateJ As Date

LigMax = Range("D" & Rows.Count).End(xlUp).Row 'Identifie la dernière ligne à traiter
DateJ = CDate(Replace(Range("A9"), "#", "")) 'Convertie la cellule A9 en date
With Sheets("rendu") 'Tout objet commençant par "." s'y rapporte
    Cells.Copy .Range("A1") 'Copie de l'onglet SLA
    For Lig = 10 To LigMax 'Parcourir les lignes
        .Range("A" & Lig) = Range("B" & Lig) 'Reporter la colonne 2 (B) en colonne 1 (A)
        .Range("D" & Lig) = DateJ 'Mettre la date en colonne 4 (D)
    Next Lig
    .Rows(9).Delete 'Supprimer la ligne 9
End With

End Sub

Dans ton fichier :

6transpose.xlsm (511.68 Ko)

Bonjour

Bonjour à tous

Une variante à tester.

Bye !

7transpose-v1.xlsb (238.07 Ko)

Salut barachoie,

salut Pedro, gmb,

et une petite dernière...

Double-clic sur 'SLA' pour démarrer la macro...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract(), iIdx!, sData$
'
Cancel = True
'
tData = Range("A1").Resize(Range("B" & Rows.Count).End(xlUp).Row, UsedRange.Columns.Count).Value
For x = 1 To UBound(tData, 1)
    If Left(tData(x, 1), 1) <> "#" Then
        iIdx = iIdx + 1
        ReDim Preserve tExtract(UBound(tData, 2), iIdx)
        For y = 1 To UBound(tData, 2)
            tExtract(y - 1, iIdx - 1) = IIf(y = 1 And sData <> "", tData(x, 2), IIf(y = 4, sData, tData(x, y)))
        Next
    Else
        sData = Replace(tData(x, 1), "#", "")
    End If
Next
With Worksheets("Extract")
    .Cells.Delete
    .Range("A1").Resize(iIdx, UBound(tData, 2)).Value = WorksheetFunction.Transpose(tExtract)
    .Columns("D").AutoFit
    .Activate
End With
'
End Sub

A+

7transpose.xlsm (219.54 Ko)

Bonjour Pedro22, Gmb et Curulis57

Merci à vous trois pour votre travail

La premiere Version de Pedro22 ne font pas ressortir les Dates successifs

Version de Gmb ne semble pas deleter les "###Date en fin de traitement

Version de Curulis57 le résultat et là.

En big Datas la Version de Pedro22 tjrs la faiblesse des Dates

la Version de Gmb ne supprime pas les anciennes Dates et ne font plus ressortir les Dates successifs

la Version de Curulis57 hyper long pour la restitution et ne font plus ressortir les Dates successifs

ci-joint une fraction de BigDatas avec vos differentes Macros par bouton sauf Curulis57 en double click

Bien cordialement

9bigdats.xlsb (461.64 Ko)

La premiere Version de Pedro22 ne font pas ressortir les Dates successifs

Je n'avais pas prêté attention à la présence d'autres dates dans le fichier... Voilà mon code révisé pour en tenir compte :

Sub RemanierData()

Dim LigMax As Long, Lig As Long, DateJ As Date

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

LigMax = Range("D" & Rows.Count).End(xlUp).Row 'Identifie la dernière ligne à traiter
With Sheets("rendu") 'Tout objet commençant par "." s'y rapporte
    Cells.Copy .Range("A1") 'Copie de l'onglet SLA
    For Lig = 9 To LigMax 'Parcourir les lignes
        If Left(.Range("A" & Lig), 1) = "#" Then
            DateJ = CDate(Replace(.Range("A" & Lig), "#", "")) 'Convertie la cellule A en date
            .Rows(Lig).ClearContents
        End If
        .Range("A" & Lig) = Range("B" & Lig) 'Reporter la colonne 2 (B) en colonne 1 (A)
        .Range("D" & Lig) = DateJ 'Mettre la date en colonne 4 (D)
    Next Lig
    For Lig = LigMax To 9 Step -1 'Parcourir les lignes
        If IsEmpty(.Range("A" & Lig)) Then .Rows(Lig).Delete 'Supprimer la ligne de date
    Next Lig
End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Salut barachoie,

!!! Saboteur !!!

Non, mais!

Sheets("SLA").Select
    Range("A10:A23000").Select
    Selection.ClearContents

Quand tu ajoutes du code, assure-toi de ses effets... pervers!

Supprime le code ci-dessus de ma macro!

3-4 secondes : hyper-long ?

A+

Curulis57,

si si je t'assure

le bigbigDatas c'est 3 minutes Minimum et si j'efface pas les contenus de A et bien les trois versions

sont inopérant sur la copie sur la gauche et pour les Dates pas de progression.

Ci-joint le 1/5eme d'un BigBigDatas tu m'en diras des nouvelles

6bigbigdatas.xlsb (0.99 Mo)

Pedro22 bonsoir et Merci,

Le dernier code reste inopérant sur les changements de Dates

Ton code reste trés rapide

au plaisir de te relire

bien cordialement

Salut barachoie,

sans effacer la colonne [A], surtout pas, en ayant "créé" un Big Data de 100.000 lignes : 6,75 secondes avec progression des dates et tout et tout...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, sData$
'
Cancel = True
'
tData = Range("A1").Resize(Range("B" & Rows.Count).End(xlUp).Row, UsedRange.Columns.Count).Value
For x = 9 To UBound(tData, 1)
    If Left(tData(x, 1), 1) = "#" Then
        sData = Replace(tData(x, 1), "#", "")
        tData(x, 1) = ""
    Else
        tData(x, 1) = tData(x, 2)
        tData(x, 4) = sData
    End If
Next
With Worksheets("Extract")
    .Cells.Delete
    .Range("A1").Resize(UBound(tData, 1), UBound(tData, 2)).Value = tData
    .Range("A9:A" & UBound(tData, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .Columns("D").AutoFit
    .Activate
End With
'
End Sub

A+

Curulis57 bonjour et Merci ,

c'est Parfait Rapide et sans bavure, Merci pour ton excellent code

Merci également a Gmb et Pedro22 pour leurs aides

Bien cordialement

Rechercher des sujets similaires à "reorganiser onglet"