Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Autres Insérer une ligne

Créer une discussion

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 à toutes & à tous,
bonjour @francescofrancesco
J'ai remarqué un petit bug voici une version "corrigée" (si je ne me trompe pas !) 🙄
code de la macro
VB: 
Private Sub CBn_Registrare_Click()
    
     Dim f As Worksheet, Tablo, NbL As Long, NewRecord(1 To 1, 1 To 10)
     Dim txt As String, x1, x2, x3x4, x5, x6, x7, x8, x9, x10, Idx As Long
     Dim n, primariga As String, secondariga As String
     Const NbC As Byte = 10, Sép As String = "."
    
     Set f = Foglio1
     With f
          NbL = .Cells(.Rows.Count, 1).End(xlUp).Row
          If NbL = 1 Then NbL = 2
          Tablo = .Range(.Cells(2, 1), .Cells(NbL, 10)).Value2
          NbL = UBound(Tablo, 1)
     End With
    
     x3 = Me.TBx_causale
    
     txt = Me.TBx_operazioni2
     secondariga = ""
     If txt <> "" Then
          n = Split(txt, vbCrLf, 2)
          primariga = n(0)
          If UBound(n) = 1 Then
               secondariga = Replace(n(1), vbCrLf, " ")
          End If
     Else
          primariga = ""
     End If
    
     txt = Me.TBx_operazioni
     If txt <> "" Then
          x4 = UCase(Replace(txt, vbCrLf, " ")) & vbNewLine & LCase(primariga) & " " & LCase(Trim(secondariga))
     Else
          x4 = UCase(primariga) & " " & LCase(Trim(secondariga))
     End If
    
     x5 = CDbl(Evaluate("0" & Replace(Me.TBx_entrate, ",", Sép)))
     x6 = CDbl(Evaluate("0" & Replace(Me.TBX_uscite, ",", Sép)))
     x7 = CDbl(Evaluate("0" & Replace(Me.TBx_sospesi, ",", Sép)))
     x8 = CDbl(Evaluate("0" & Replace(Me.TBx_fuoricassa, ",", Sép)))
     x9 = x1
    
     txt = Me.TBx_data.Text
     If txt <> "" Then
          x2 = CDate(txt): x1 = CLng(x2)

debut = Timer
          NewRecord(1, 2) = x1
          NewRecord(1, 3) = x3
          NewRecord(1, 4) = x4
          NewRecord(1, 5) = x5
          NewRecord(1, 6) = x6
          NewRecord(1, 7) = x5 - x6
          NewRecord(1, 8) = x7
          NewRecord(1, 9) = x8
          NewRecord(1, 10) = x1
    
          Idx = -1
          On Error Resume Next
               With WorksheetFunction: Idx = .Match(x1, .Index(Tablo, 0, 10), 1): End With
          On Error GoTo 0
          If Idx = -1 Then
               MsgBox "Echec sur position de la date !"
               Exit Sub
          End If
          If Mid(Tablo(Idx + 1, 4), 1, 2) = "CD" Then Idx = Idx - 1
          
          ReDim TabloRés(1 To NbL + 1, 1 To 10)
          k = 0
          For i = 1 To Idx
               k = k + 1
               For j = 2 To 10
                    TabloRés(i, 1) = k
                    TabloRés(i, j) = Tablo(i, j)
               Next j
          Next
          k = k + 1
          For j = 2 To 10
               TabloRés(Idx + 1, 1) = k
               TabloRés(Idx + 1, j) = NewRecord(1, j)
          Next j
          For i = Idx + 2 To NbL + 1
               k = k + 1
               For j = 2 To 10
                    TabloRés(i, 1) = k
                    TabloRés(i, j) = Tablo(i - 1, j)
               Next j
          Next
          
          Set rg = f.Cells(2, 1).Resize(NbL + 1, 10)
          rg.Value2 = TabloRés

CreateObject("wscript.shell").popup "Terminé en " & Timer - debut & " secondes", 5, "durée"
     End If

'prog          1
'Data          2
'causale       3
'movimenti     4
'entrate       5
'uscite        6
'saldo         7
'sospesi       8
'fuoricassa    9
'numero Data   10

'prog          TBx_prog
'data          TBx_Data            TextBox1
'causale       TBx_causale         TextBox2
'operazioni    TBx_operazioni      Textbox30
'operazioni    TBx_operazioni2     TextBox3
'entrate       TBx_entrate         TextBox4
'uscite        TBX_uscite          TextBox5
'sospesi       TBx_sospesi         TextBox6
'fuoricassa    TBx_fuoricassa      TextBox7

End Sub



voir pièce jointe

À bientôt
 

Pièces jointes

Vote positif 0 Vote négatif
Oui, des zones de texte inversées.
J'ai juste besoin d'une explication sur ce morceau de code. Merci.
VB: 
 ReDim TabloRés(1 To NbL + 1, 1 To 10)
          k = 0
          For i = 1 To Idx
               k = k + 1
               For j = 2 To 10
                    TabloRés(i, 1) = k
                    TabloRés(i, j) = Tablo(i, j)
               Next j
          Next
          k = k + 1
          For j = 2 To 10
               TabloRés(Idx + 1, 1) = k
               TabloRés(Idx + 1, j) = NewRecord(1, j)
          Next j
          For i = Idx + 2 To NbL + 1
               k = k + 1
               For j = 2 To 10
                    TabloRés(i, 1) = k
                    TabloRés(i, j) = Tablo(i - 1, j)
               Next j
          Next
 
Vote positif 0 Vote négatif
Bonsoir à toutes & à tous,
bonsoir @francescofrancesco

  • Le tableau NewRecord contient les informations de la nouvelle ligne à insérer. (1 lignes et 10 colonnes)
  • Le tableau TabloRés contient une ligne de plus que Tablo (qui contient les données de la liste avant modification)
    Tablo : Nbl lignes et 10 colonnes TabloRés : NbL+1 lignes et 10 colonnes
  • idx est le N° de ligne juste avant l'insertion.
  • k est le compteur pour la colonne "prog"
cette partie fonctionne de la manière suivante
  1. de 1 à idx on recopie simplement les colonnes 2 à 10 de Tablo dans TabloNew puisque ces lignes n'ont pas changé.
    (On met k dans la colonne "prog" mais on pourrait reprendre la valeur de la colonne 1 de tablo)
  2. à idx +1 on copie dans TabloRés les colonnes de NewRecord (sauf pour la colonne "prog" où l'on met k)
  3. à partir de idx+2 on copie dans TabloRés les colonnes de Tablo mais avec un décalage de -1 à cause de l'ajout de ligne qu'on à effectuer dans TabloRés (et toujours k dans la colonne "prog")
Voilà, note que l'on refait la numérotation de la colonne "prog" à la volée. le tableau TabloRés est plaqué en une seule fois sur la plage cible qui augmente d'une ligne.

Moi aussi j'ai une question :
à quoi correspond ce saut de ligne arrière : if Mid(Tablo(Idx + 1, 4), 1, 2) = "CD" Then Idx = Idx - 1 ?​
et une remarque :
Tu as un exemple de ligne vierge parmi une plage de même date (le 04/01/2022) en conséquence Match renvoie la dernière ligne du premier bloc avant la ligne vide et non pas la dernière occurence de cette date. À corriger sans doute ...​

À bientôt
 
Vote positif 0 Vote négatif
Bonjour.
La ligne vide sépare chaque groupe de cellules ayant la même date.
VB: 
With f
Set tx = .Range("A1:S" & .Cells(Rows.count, 1).End(xlUp).row)
End With
With tx
        ncol = .Columns.count
        If ncol = 1 Then ncol = 2
        tablo = .Resize(.Rows.count + 1, ncol)
        ReDim resu(1 To Rows.count, 1 To ncol)
        For i = 2 To UBound(tablo) - 1
            n = n + 1
            For j = 1 To ncol
                resu(n, j) = tablo(i, j)
            Next j
            If tablo(i + 1, 2) <> tablo(i, 2) Then n = n + 1 'saut de ligne
        Next i
        If n Then .Offset(1).Resize(n - 1, ncol) = resu
    End With

If Mid(Tablo(Idx + 1, 4), 1, 2) = "CD" Alors Idx = Idx - 1
indique que la nouvelle ligne doit être placée avant la ligne contenant le mot « CD » dans la colonne 4
qui se trouve toujours à la fin de chaque bloc de cellules portant la même date.
-------------------------------------------------------------------------------------------------------------------
Donc si je comprends bien.
1-copiez les lignes au dessus de la nouvelle ligne - de 1 à idx
2-copiez la nouvelle ligne -de idx à idx+1
3-copiez les lignes en dessous de celle insérée - de idx+2 jusqu'à la fin du tableau avec Nbl+1
Merci.
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour à toutes & à tous,
Bonjour @francescofrancesco
Et qu'en est t-il des lignes du 04/01/2022 qui comportent une ligne vide en leur sein ?


Autre chose, pourquoi tu affiches ce bout de code ? :
Je peux me tromper mais mon avis :
  • If n Then .Offset(1).Resize(n - 1, ncol) = resu : if n est toujours vrai si ton "tablo" comporte au moins 2 lignes
  • Vu ta façon de définir tx ncol vaut toujours 19 (colonnes de A à S)
  • Si tu as un changement de valeur dans la colonne B tu sautes une ligne , mais par exemple,
    ligne x tu as une date,
    tu copies la ligne x
    ligne x+1 est vide donc <> de ligne x => tu sautes une ligne ,
    tu copies ligne x+1 (vide) => 2 lignes vides dans "resu"
    ligne x+2 tu as une date => tu sautes de nouveau une ligne => 3 lignes vides successives dans "resu"
    Donc cela ne fonctionne que si au départ tu n'as pas de ligne vide intercalée
...
Sinon est-ce-que ce que je t'ai envoyé te conviens ?

À bientôt
 
Vote positif 0 Vote négatif
AtTheOne à dit:
Re

ça j'avais bien compris, c'était juste une curiosité, que contient cette ligne (un sous-total, un commentaire ... ?)
Cliquez pour agrandir...
Bonjour.
Juste un oubli, il n'y a pas de lignes vides entre les lignes avec la même date.
Le code dans le fichier ci-joint peut certainement être amélioré.
 

Pièces jointes

Vote positif 0 Vote négatif
Bonsoir à toutes & à tous,
bonsoir @francescofrancesco
Oui, je comprends ton code pour le calcul du solde, mais pas celui du "Test_elimina_riga" en plus je ne parle pas italien 😉
Et j'avoue ne pas bien comprendre ta démarche : pourquoi toutes ces lignes avec uniquement la date, le calcul du solde mais aucun mouvement 🤔

Je ne sais pas non plus ce que représentent les colonnes "sospesi" et "fuoricassa" mais je ne suis pas comptable italien ! 🤗

Bon je ne sais pas en quoi je peux t'aider maintenant, si tu as un besoin peux-tu le préciser ?
À bientôt
 
Vote positif 0 Vote négatif
Bonjour.
J'ai simplifié. Les dates sont restées car j'ai supprimé les mouvements dans les cellules adjacentes.
Votre code est vraiment rapide mais peut-il être intégré pour supprimer "InsererLignesVUOTA".
Pour simplifier
« En attente » indique les achats non payés.
Achats « hors caisse » avec paiements par chèque/virement bancaire.
Merci.
 

Pièces jointes

Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
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

  • 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
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
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
606
GClaire
G
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
687
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
  • Question Question
XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante
Réponses
5
Affichages
663
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
727
Mody200
M
D
  • Question Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
2 K
Dranreb
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
2 K
Nicolas JACQUIN
E
  • Résolu(e)
XL 2019 inserer une valeur textbox dans la dernière cellule vide horizontalement
Réponses
7
Affichages
684
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
  • 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
R
  • Question Question
Microsoft 365 Supprimer les lignes vides d'une variable tableau
Réponses
1
Affichages
630
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
  • Question Question
XL 2016 Saisie formulaire dans une autre feuille
Réponses
2
Affichages
507
Cendrillon
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…