Autres Insérer une ligne

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
F

francescofrancesco

XLDnaute Junior
Bonjour, pouvez-vous optimiser ce code pour le rendre plus rapide ?
Excel 2003


VB: 
'----------------------array textbox-------------------------------------------
Dim arrA()
If UserForm33.TextBox1 <> "" Then x1 = CLng(CDate(TextBox1))
If UserForm33.TextBox1 <> "" Then x2 = CDate(UserForm33.TextBox1)                    'data fattura
x3 = UserForm33.TextBox2
On Error Resume Next
'se vuoi inserire tre righe variare il parametro a 3
'UserForm33.TextBox3.Text = Right(UserForm33.TextBox3.Text, Len(UserForm33.TextBox3.Text) - InStr(UserForm33.TextBox3.Text, vbCrLf))
n = Split(UserForm33.TextBox3, vbCr, 2)
primariga = UCase(n(0))
If n(1) <> "" Then
         secondariga = n(1)
         secondariga = Replace(secondariga, Chr(13), "")
Else
        secondariga = ""
End If
If UserForm33.TextBox30 <> "" Then
      x4 = UCase(Replace(UserForm33.TextBox30.Text, vbCr, "")) & vbNewLine & LCase(primariga) & LCase(Trim(secondariga))
Else
      x4 = UCase(primariga) & LCase(Trim(secondariga))
End If
x5 = CDbl(UserForm33.TextBox4)
x6 = CDbl(UserForm33.TextBox5)
x7 = CDbl(UserForm33.TextBox6)
x8 = CDbl(UserForm33.TextBox7)
If UserForm33.TextBox1 <> "" Then x9 = CLng(CDate(UserForm33.TextBox1))

'arrA = Array(x1, x1, x3, x4, x5, x6, " ", x7, x8, x9, x1)

If UserForm33.TextBox1 <> "" Then
           '----------verifica se la data esiste in colonna J----------------
        On Error GoTo NotFound
        'idx = Application.match(Val(dt1), Range("J2:J" & LR), 1)
        idx = Application.match(dt1, f.Range("J2:J" & f.Range("A" & f.Rows.count).End(xlUp).row), 1)
         'Rg = Application.match(Sch, ws1.Columns(10), True)
        If idx > 0 Then
        MsgBox (idx)
        'Else
        'NotFound:
         '      MsgBox ("No Match Was Found")
        'End If
     
        Application.ScreenUpdating = True
        '-----------------------------------------------------------------------------------------------------------------
        'tableau des données de la feuille "primanota"
        With f: Tablo2 = .Range(.Cells(2, 1), .Cells(.Columns(1).Cells(.Rows.count).End(xlUp).row, 10)).Value2: End With
        nbl = UBound(Tablo2, 1)
        'tableau provisoire pour Redim (col,lignes)
        ReDim TabloTemp(1 To 10, 1 To nbl)
        For i = 1 To nbl: For j = 1 To 10
        TabloTemp(j, i) = Tablo2(i, j)
        Next j: Next i
     
        If Mid(f.Cells(idx + 1, "D"), 1, 2) = "CD" Then idx = idx - 1
     
        f.Cells(idx, "A").EntireRow.Insert
        nbl = nbl + 1
        ReDim Preserve TabloTemp(1 To 10, 1 To nbl)
        For k = nbl To idx + 2 Step -1: For j = 1 To 10
        TabloTemp(j, k) = TabloTemp(j, k - 1)
        Next j: Next k
     
        TabloTemp(1, idx + 1) = x1
        TabloTemp(2, idx + 1) = x1
        TabloTemp(3, idx + 1) = x3
        TabloTemp(4, idx + 1) = x4
        TabloTemp(5, idx + 1) = x5
        TabloTemp(6, idx + 1) = x6
        TabloTemp(8, idx + 1) = x7
        TabloTemp(9, idx + 1) = x8
        TabloTemp(10, idx + 1) = x1
     
        '      For i = 1 To nbl
        '      TabloTemp(1, i) = i
        '      Next
        '      f.Cells(2, 1).Resize(nbl, 10).Value = Application.Transpose(TabloTemp)
     
        ar = WorksheetFunction.Transpose(TabloTemp)
        f.Cells(2, 1).Resize(UBound(ar, 1), UBound(ar, 2)).Value = ar
     
        Else
NotFound:
               MsgBox ("No Match Was Found")
        End If
End If
 
Dernière édition:
Trier par date Trier par votes
Bonjour francescofrancesco, AtTheOne, Lionel, le forum,

J'ai juste regardé le fichier du post #1 et je vois qu'il faut complètement modifier le code.

J'ai mis 3 boutons avec ces macros dans Module1 :
VB: 
Const ncol% = 9 'mémorise la constante

Sub Ajout_date()
UserForm33.Show
End Sub

Sub Tri()
With ActiveSheet.UsedRange.Resize(, ncol): .Sort .Columns(1), xlAscending, Header:=xlYes: End With 'tri sur les dates
Rows(Range("A" & Rows.Count).End(xlUp).Row + 1 & ":" & Rows.Count).Delete 'RAZ
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Sub Ajout_lignes_vides()
Dim t, tablo, resu(), n&, i&, j%
t = Timer
Application.ScreenUpdating = False
Tri 'supprime les lignes vides
With ActiveSheet.UsedRange.Resize(, ncol)
    tablo = .Value 'matrice, plus rapide
    ReDim resu(1 To 2 * UBound(tablo), 1 To ncol)
    n = -1
    For i = 2 To UBound(tablo)
        If tablo(i, 1) = tablo(i - 1, 1) Then n = n + 1 Else n = n + 2
        For j = 1 To ncol
            resu(n, j) = tablo(i, j)
    Next j, i
    If n > 0 Then .Rows(2).Resize(n) = resu 'restitution
End With
Application.ScreenUpdating = True
MsgBox "Durée du traitement " & Format(Timer - t, "0.00 \sec")
End Sub
Le code de l'UserForm est très simple :
VB: 
Private Sub CommandButton1_Click()
If Not IsDate(TextBox1) Then TextBox1 = "": TextBox1.SetFocus: Exit Sub
Dim lig&
Application.ScreenUpdating = False
lig = ActiveSheet.UsedRange.Rows.Count + 1
Cells(lig, 1) = CLng(CDate(TextBox1))
Cells(lig, 2) = TextBox2
Cells(lig, 3) = TextBox30 & vbLf & TextBox3
Cells(lig, 4) = Val(Replace(TextBox4, ",", "."))
Cells(lig, 5) = Val(Replace(TextBox5, ",", "."))
Cells(lig, 7) = Val(Replace(TextBox6, ",", "."))
Cells(lig, 8) = Val(Replace(TextBox7, ",", "."))
Cells(lig, 9) = Cells(lig, 1).Value2
Ajout_lignes_vides 'lance la macro
End Sub
Sur ce fichier l'exécution est quasi instantanée.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
job75 à dit:
Bonjour francescofrancesco, AtTheOne, Lionel, le forum,

J'ai juste regardé le fichier du post #1 et je vois qu'il faut complètement modifier le code.

J'ai mis 3 boutons avec ces macros dans Module1 :
VB: 
Const ncol% = 9 'mémorise la constante

Sub Ajout_date()
UserForm33.Show
End Sub

Sub Tri()
With ActiveSheet.UsedRange.Resize(, ncol): .Sort .Columns(1), xlAscending, Header:=xlYes: End With 'tri sur les dates
Rows(Range("A" & Rows.Count).End(xlUp).Row + 1 & ":" & Rows.Count).Delete 'RAZ
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Sub Ajout_lignes_vides()
Dim t, tablo, resu(), n&, i&, j%
t = Timer
Application.ScreenUpdating = False
Tri 'supprime les lignes vides
With ActiveSheet.UsedRange.Resize(, ncol)
    tablo = .Value 'matrice, plus rapide
    ReDim resu(1 To 2 * UBound(tablo), 1 To ncol)
    n = -1
    For i = 2 To UBound(tablo)
        If tablo(i, 1) = tablo(i - 1, 1) Then n = n + 1 Else n = n + 2
        For j = 1 To ncol
            resu(n, j) = tablo(i, j)
    Next j, i
    If n > 0 Then .Rows(2).Resize(n) = resu 'restitution
End With
Application.ScreenUpdating = True
MsgBox "Durée du traitement " & Format(Timer - t, "0.00 \sec")
End Sub
Le code de l'UserForm est très simple :
VB: 
Private Sub CommandButton1_Click()
If Not IsDate(TextBox1) Then TextBox1 = "": TextBox1.SetFocus: Exit Sub
Dim lig&
Application.ScreenUpdating = False
lig = ActiveSheet.UsedRange.Rows.Count + 1
Cells(lig, 1) = CLng(CDate(TextBox1))
Cells(lig, 2) = TextBox2
Cells(lig, 3) = TextBox30 & vbLf & TextBox3
Cells(lig, 4) = Val(Replace(TextBox4, ",", "."))
Cells(lig, 5) = Val(Replace(TextBox5, ",", "."))
Cells(lig, 7) = Val(Replace(TextBox6, ",", "."))
Cells(lig, 8) = Val(Replace(TextBox7, ",", "."))
Cells(lig, 9) = Cells(lig, 1).Value2
Ajout_lignes_vides 'lance la macro
End Sub
Sur ce fichier l'exécution est quasi instantanée.

A+
Cliquez pour agrandir...
Bonjour.
job75
0,05
sans équilibre des colonnes et sans chargement de la listbox
-------------------------------------------------------------------
AtTheOne
0,06
avec équilibrage des colonnes et sans chargement de la liste déroulante

Pouvez-vous m'aider avec le fichier du post 21,
Merci.
 
Dernière édition:
Vote positif 0 Vote négatif
Je ne vois pas l'utilité d'une ListBox pour ce problème.

Dans ce fichier (2) j'ai ajouté le bouton Modifier et un SpinButton (Toupie) dans l'UserForm.

Le code dans Module1 :
VB: 
Const ncol% = 9 'mémorise la constante

Sub Modifier()
Dim s As Boolean
s = ThisWorkbook.Saved
Tri 'supprime les lignes vides
UserForm33.Caption = "Modifier"
UserForm33.SpinButton1.Max = Rows.Count
UserForm33.Show
If Application.CountBlank(ActiveSheet.UsedRange.Columns(1)) = 0 Then _
    Ajout_lignes_vides: ThisWorkbook.Saved = s 'évite l'invite à la fermeture si aucune modification
End Sub

Sub Ajout_date()
UserForm33.Caption = "Ajout date"
UserForm33.SpinButton1.Visible = False
UserForm33.Show
End Sub

Sub Tri()
With ActiveSheet.UsedRange.Resize(, ncol): .Sort .Columns(1), xlAscending, Header:=xlYes: End With 'tri sur les dates
Rows(Range("A" & Rows.Count).End(xlUp).Row + 1 & ":" & Rows.Count).Delete 'RAZ
Rows("2:" & Rows.Count).AutoFit 'ajuste la hauteur
With ActiveSheet.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Sub Ajout_lignes_vides()
Dim t, tablo, resu(), n&, i&, j%
't = Timer
Application.ScreenUpdating = False
Tri 'supprime les lignes vides
With ActiveSheet.UsedRange.Resize(, ncol)
    tablo = .Value 'matrice, plus rapide
    ReDim resu(1 To 2 * UBound(tablo), 1 To ncol)
    n = -1
    For i = 2 To UBound(tablo)
        If tablo(i, 1) = tablo(i - 1, 1) Then n = n + 1 Else n = n + 2
        For j = 1 To ncol
            resu(n, j) = tablo(i, j)
    Next j, i
    If n > 0 Then .Rows(2).Resize(n) = resu 'restitution
End With
Rows("2:" & Rows.Count).AutoFit 'ajuste la hauteur
Application.ScreenUpdating = True
'MsgBox "Durée du traitement " & Format(Timer - t, "0.00 \sec")
End Sub
Vu la rapidité du traitement je ne vois pas l'intérêt d'utiliser le Timer.

Pour tester j'ai créé un fichier .xlsm avec 150 000 dates différentes : l'exécution se fait en 2,7 secondes chez moi.

Le nouveau code de l'UserForm :
VB: 
Dim lig As Variant, flag As Boolean 'mémorise les variables

Private Sub CommandButton1_Click()
If Not IsDate(TextBox1) Then TextBox1 = "": TextBox1.SetFocus: Exit Sub
If Not SpinButton1.Visible Then lig = ActiveSheet.UsedRange.Rows.Count + 1
Application.ScreenUpdating = False
Cells(lig, 1) = CLng(CDate(TextBox1))
Cells(lig, 2) = TextBox2
Cells(lig, 3) = TextBox30 & IIf(TextBox3 <> "", vbLf & TextBox3, "")
Cells(lig, 4) = Val(Replace(TextBox4, ",", "."))
Cells(lig, 5) = Val(Replace(TextBox5, ",", "."))
Cells(lig, 7) = Val(Replace(TextBox6, ",", "."))
Cells(lig, 8) = Val(Replace(TextBox7, ",", "."))
Cells(lig, 9) = Cells(lig, 1).Value2
Ajout_lignes_vides 'lance la macro
Unload Me
End Sub

Private Sub TextBox1_Change()
Dim s
If Not SpinButton1.Visible Or Not IsDate(TextBox1) Or Not TextBox1 Like "*/*/??*" Then Exit Sub
If flag Then
    TextBox1 = Cells(lig, 1)
Else
    lig = Application.Match(CLng(CDate(TextBox1)), Columns(1), 0)
    If IsError(lig) Then MsgBox "Cette date n'a pas encore été créée...": TextBox1 = "": TextBox1.SetFocus: Exit Sub
End If
TextBox2 = Cells(lig, 2)
s = Split(Cells(lig, 3), vbLf)
If UBound(s) >= 0 Then TextBox30 = s(0) Else TextBox30 = ""
If UBound(s) > 0 Then TextBox3 = s(1) Else TextBox3 = ""
TextBox4 = Cells(lig, 4)
TextBox5 = Cells(lig, 5)
TextBox6 = Cells(lig, 7)
TextBox7 = Cells(lig, 8)
Label9 = "Ligne " & lig
SpinButton1 = lig
End Sub

Private Sub SpinButton1_SpinDown()
If IsError(lig) Then Exit Sub
If lig = Rows.Count Then Exit Sub
lig = lig + 1
flag = True: TextBox1_Change: flag = False
End Sub

Private Sub SpinButton1_SpinUp()
If IsError(lig) Then Exit Sub
If lig = 2 Then Exit Sub
lig = lig - 1
flag = True: TextBox1_Change: flag = False
End Sub
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Bonjour francescofrancesco, le forum,

Je ne sais pas si vous en êtes conscient mais utiliser le type de fichier .xls qui a plus de 20 ans est une pure hérésie.

Utilisez donc un fichier .xlsm et profitez-en pour créer un tableau structuré.

Pour séparer les dates il vaut beaucoup mieux utiliser une Mise en forme conditionnelle (MFC) plutôt que des lignes vides.

Dans le fichier joint il ne reste que 3 boutons avec ce code :
VB: 
Sub Modifier()
UserForm33.Caption = "Modifier"
UserForm33.SpinButton1.Max = Rows.Count
UserForm33.Show
End Sub

Sub Ajout_date()
UserForm33.Caption = "Ajout date"
UserForm33.SpinButton1.Visible = False
UserForm33.Show
End Sub

Sub Tri()
Dim tablo, i&, dat&, n&, temp&, c As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
With [Tableau1] 'tableau structuré
    .FormatConditions.Delete 'supprime toutes les MFC
    .Sort .Columns(2), xlAscending, Header:=xlYes 'tri sur les dates
    .Rows(1).Borders.Weight = xlHairline 'bordures
    If .Rows.Count > 1 Then .Rows(1).AutoFill .Rows, xlFillFormats 'propage les formats
    tablo = .Resize(, 2).Value2 'matrice, plus rapide
    For i = 1 To UBound(tablo)
        dat = tablo(i, 2)
        tablo(i, 1) = n - (dat <> temp)
        n = tablo(i, 1): temp = dat
    Next i
    .Columns(1) = tablo 'restitution
    Set c = .Cells(0, .Columns.Count + 2) 'cellule auxiliaire L1
    c = "=MOD(" & .Cells(1).Address(0, 1) & ",2)" '=MOD($A2,2)
    .FormatConditions.Add xlExpression, Formula1:=c.FormulaLocal 'recrée la MFC
    .FormatConditions(1).Interior.Color = RGB(253, 233, 217) 'couleur modifiable
    .Rows.AutoFit 'ajuste la hauteur
    With .Parent.UsedRange: End With 'actualise la barre de défilement verticale
End With
Application.EnableEvents = True
End Sub
Avec un tableau de 150 000 dates la macro Tri s'exécute chez moi en 0,6 seconde, il n'y a donc pas de problème.

Cette macro dans le code de la feuille l'exécute chaque fois qu'une cellule est modifiée ou validée :
VB: 
Private Sub Worksheet_Change(ByVal Target As Range)
Tri
End Sub
A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

patricktoulon
  • Question Question
Microsoft 365 datepicker dynamique intra userform ou dans feuille 2 versions(frame dynamique)(toute version d'excel )
4 5 6
Réponses
86
Affichages
1 K
patricktoulon
patricktoulon
S
  • Question Question
Microsoft 365 créer un macro vba
Réponses
0
Affichages
481
souhaib ad
S
G
  • Question Question
XL 2016 Compte à rebours dans un userform
2
Réponses
15
Affichages
775
patricktoulon
patricktoulon
E
  • Question Question
Microsoft 365 Listbox avec plus de 10 colonnes
Réponses
6
Affichages
679
Excellearning
E
G
  • Question Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
604
GClaire
G
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
685
AtTheOne
AtTheOne
B
  • Résolu(e)
Microsoft 365 affecter des valeurs dans un tableau de noms de variable
Réponses
4
Affichages
858
bérylion
B
petitbuzuc
  • Question Question
XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante
Réponses
5
Affichages
661
fanch55
fanch55
M
  • Question Question
XL 2010 Calcul possible dans la zone de liste pour le débit et le crédit lors d'une recherche basée sur la zone de texte
Réponses
0
Affichages
725
Mody200
M
D
  • Question Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
2 K
Dranreb
Dranreb
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
Nicolas JACQUIN
E
  • Résolu(e)
XL 2019 inserer une valeur textbox dans la dernière cellule vide horizontalement
Réponses
7
Affichages
683
escudo
E
J
  • Question Question
Mon code tourne a l'infini et se plante
Réponses
5
Affichages
527
JessK
J
P
  • Résolu(e)
Microsoft 365 Erreur d'exécution "9" :L'indice n'appartient pas à la sélection
Réponses
9
Affichages
2 K
pelerin65
P
F
  • Résolu(e)
XL 2019 Effacer toute une ligne de cellules mais uniquement à l’intérieur d’un tableau
Réponses
14
Affichages
1 K
Formulatix
F
Dadi147
  • Résolu(e)
XL 2019 Le problème de la suppression des virgules lors de la modification des valeurs Listbox
Réponses
5
Affichages
753
Dadi147
Dadi147
R
  • Question Question
Microsoft 365 Supprimer les lignes vides d'une variable tableau
Réponses
1
Affichages
630
Phil69970
Phil69970
A
  • Question Question
XL 2019 Vérifier si une ligne existe dans un autre fichier
Réponses
7
Affichages
750
A-F
A
Y
  • Résolu(e)
XL 2019 vérifier des check dans une listview
Réponses
3
Affichages
583
youguybass
Y
Cendrillon
  • Question Question
XL 2016 Saisie formulaire dans une autre feuille
Réponses
2
Affichages
507
Cendrillon
Cendrillon
Retour