XL 2016 Extrayez les dates des factures et recopiez-les sur la dernière ligne de la facture vba

Dadi147 · 30 Décembre 2022

Bonjour .cv puis-je copier la cellule E2 le long de la colonne de facture B En commençant par la cellule B6 et copier la date dans la colonne A avec la cellule A6
Jusqu’à la dernière ligne du premier projet de loi, puis la même chose sera répétée sur les projets de loi suivants
Ainsi, lorsque vous ajoutez une nouvelle facture, ses données sont copiées dans les mêmes colonnes pour modifier le nom de la date que dans le fichier joint

job75 · 31 Décembre 2022

Bonjour Dadi147, jm.andryszak, le forum,

Vous pouvez utiliser cette macro :

VB:

Sub Remplir_tout()
Dim nmax&, a$(), derlig&, tablo, i&, n&, c As Range, dat$, h&
With Sheets("Sheet1")
    '---liste des adresses---
    nmax = Application.CountIf(.[E:E], "Restaurant*")
    ReDim a(nmax) 'base 0
    derlig = .Range("C" & .Rows.Count).End(xlUp).Row + 1
    a(nmax) = "E" & derlig 'dernier élément
    tablo = .Range("E1:F" & derlig) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To derlig
        If Trim(tablo(i, 1)) Like "Restaurant*" Then a(n) = "E" & i: n = n + 1
    Next i
    '---remplissage des colonnes A et B
    Application.ScreenUpdating = False
    .[A:B].ClearContents 'RAZ
    .[A:B].HorizontalAlignment = xlCenter...

job75 · 30 Décembre 2022

Bonsoir Dadi147,

Exécutez cette macro :

VB:

Sub Remplir()
Dim c As Range, dat, h&
With Sheets("Sheet1")
    Set c = .Columns("E").Find("Restaurant*", , xlValues, , , xlPrevious)
    dat = Mid(Trim(c(7, 0)), 11, 10)
    h = .Range("C" & .Rows.Count).End(xlUp).Row - c(5).Row
    If h < 1 Then Exit Sub
    If IsDate(dat) Then c(6, -3).Resize(h) = CDate(dat)
    c(6, -2).Resize(h) = c(2)
    c(6, -3).Resize(h, 2).HorizontalAlignment = xlCenter 'centrage
End With
End Sub

Bonne nuit.

Dadi147 · 31 Décembre 2022

job75 à dit:

Bonsoir Dadi147,

Exécutez cette macro :

VB:

Sub Remplir()
Dim c As Range, dat, h&
With Sheets("Sheet1")
    Set c = .Columns("E").Find("Restaurant*", , xlValues, , , xlPrevious)
    dat = Mid(Trim(c(7, 0)), 11, 10)
    h = .Range("C" & .Rows.Count).End(xlUp).Row - c(5).Row
    If h < 1 Then Exit Sub
    If IsDate(dat) Then c(6, -3).Resize(h) = CDate(dat)
    c(6, -2).Resize(h) = c(2)
    c(6, -3).Resize(h, 2).HorizontalAlignment = xlCenter 'centrage
End With
End Sub

Bonne nuit.

Merci beaucoup
Le code fonctionne bien pour vous, mais seules les données de la dernière facture sont copiées, est-il possible de remplir une facture vierge ?

jm.andryszak · 31 Décembre 2022

Bonjour
Essayez ceci, je n'ai pas trouvé d'erreur.
Sub ToutesLesFacturesVierges()
Dim i
Dim Formule
For i = 1 To Range("c" & Rows.Count).End(xlUp).Row
If InStr(1, Range("e" & i).Value, "Restaurant", vbTextCompare) > 0 Then
'NB.SI
Formule = "=" & "COUNTIF(" & "a" & i & ":" & "a" & i + 72 & "," & """""" & ")" & "+" & "COUNTIF(" & "b" & i & ":" & "b" & i + 72 & "," & """""" & ")"
'Seules les 5 premieres lignes de la facture sont vides en colonne A et B ==> 10
If Evaluate(Formule) <> 10 Then
Remplir Range("e" & i), 68 '73 - les 5 premieres lignes de la facture
End If
End If
Next
End Sub
'***********************************************
Sub ToutesLesFactures()
Dim i
For i = 1 To Range("c" & Rows.Count).End(xlUp).Row
If InStr(1, Range("e" & i).Value, "Restaurant", vbTextCompare) > 0 Then
Remplir Range("e" & i), 68 '73 - les 5 premieres lignes de la facture
End If
Next
End Sub
'***********************************************
Sub Remplir(C As Range, h)
Dim dat
With Sheets("Sheet1")
dat = Mid(Trim(C(7, 0)), 11, 10)
'If h < 1 Then Exit Sub
If IsDate(dat) Then C(6, -3).Resize(h) = CDate(dat)
C(6, -2).Resize(h) = C(2)
C(6, -3).Resize(h, 2).HorizontalAlignment = xlCenter 'centrage
End With
End Sub
'***********************************************

job75 · 31 Décembre 2022

Bonjour Dadi147, jm.andryszak, le forum,

Vous pouvez utiliser cette macro :

VB:

Sub Remplir_tout()
Dim nmax&, a$(), derlig&, tablo, i&, n&, c As Range, dat$, h&
With Sheets("Sheet1")
    '---liste des adresses---
    nmax = Application.CountIf(.[E:E], "Restaurant*")
    ReDim a(nmax) 'base 0
    derlig = .Range("C" & .Rows.Count).End(xlUp).Row + 1
    a(nmax) = "E" & derlig 'dernier élément
    tablo = .Range("E1:F" & derlig) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To derlig
        If Trim(tablo(i, 1)) Like "Restaurant*" Then a(n) = "E" & i: n = n + 1
    Next i
    '---remplissage des colonnes A et B
    Application.ScreenUpdating = False
    .[A:B].ClearContents 'RAZ
    .[A:B].HorizontalAlignment = xlCenter 'centrage
    For n = 0 To UBound(a) - 1
        Set c = .Range(a(n))
        dat = Mid(Trim(c(7, 0)), 11, 10)
        h = .Range(a(n + 1)).Row - 1 - c(5).Row
        If h > 0 Then
            If IsDate(dat) Then c(6, -3).Resize(h) = CDate(dat)
            c(6, -2).Resize(h) = c(2)
        End If
    Next n
End With
End Sub

Par curiosité, à quoi vont vous servir les colonnes A et B ?

A+

job75 · 31 Décembre 2022

J'ai testé en recopiant la plage C1:G73 sur 73 000 lignes (1000 factures).

La macro s'exécute chez moi en 0,4 seconde.

Dadi147 · 31 Décembre 2022

job75 à dit:

Bonjour Dadi147, jm.andryszak, le forum,

Vous pouvez utiliser cette macro :

VB:

Sub Remplir_tout()
Dim nmax&, a$(), derlig&, tablo, i&, n&, c As Range, dat$, h&
With Sheets("Sheet1")
    '---liste des adresses---
    nmax = Application.CountIf(.[E:E], "Restaurant*")
    ReDim a(nmax) 'base 0
    derlig = .Range("C" & .Rows.Count).End(xlUp).Row + 1
    a(nmax) = "E" & derlig 'dernier élément
    tablo = .Range("E1:F" & derlig) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To derlig
        If Trim(tablo(i, 1)) Like "Restaurant*" Then a(n) = "E" & i: n = n + 1
    Next i
    '---remplissage des colonnes A et B
    Application.ScreenUpdating = False
    .[A:B].ClearContents 'RAZ
    .[A:B].HorizontalAlignment = xlCenter 'centrage
    For n = 0 To UBound(a) - 1
        Set c = .Range(a(n))
        dat = Mid(Trim(c(7, 0)), 11, 10)
        h = .Range(a(n + 1)).Row - 1 - c(5).Row
        If h > 0 Then
            If IsDate(dat) Then c(6, -3).Resize(h) = CDate(dat)
            c(6, -2).Resize(h) = c(2)
        End If
    Next n
End With
End Sub

Par curiosité, à quoi vont vous servir les colonnes A et B ?

A+

Merci beaucoup. C'est ce dont nous avons vraiment besoin. Vous êtes un génie. Salutations à vous.

Dadi147 · 31 Décembre 2022

jm.andryszak à dit:
Bonjour
Essayez ceci, je n'ai pas trouvé d'erreur.
Sub ToutesLesFacturesVierges()
Dim i
Dim Formule
For i = 1 To Range("c" & Rows.Count).End(xlUp).Row
If InStr(1, Range("e" & i).Value, "Restaurant", vbTextCompare) > 0 Then
'NB.SI
Formule = "=" & "COUNTIF(" & "a" & i & ":" & "a" & i + 72 & "," & """""" & ")" & "+" & "COUNTIF(" & "b" & i & ":" & "b" & i + 72 & "," & """""" & ")"
'Seules les 5 premieres lignes de la facture sont vides en colonne A et B ==> 10
If Evaluate(Formule) <> 10 Then
Remplir Range("e" & i), 68 '73 - les 5 premieres lignes de la facture
End If
End If
Next
End Sub
'***********************************************
Sub ToutesLesFactures()
Dim i
For i = 1 To Range("c" & Rows.Count).End(xlUp).Row
If InStr(1, Range("e" & i).Value, "Restaurant", vbTextCompare) > 0 Then
Remplir Range("e" & i), 68 '73 - les 5 premieres lignes de la facture
End If
Next
End Sub
'***********************************************
Sub Remplir(C As Range, h)
Dim dat
With Sheets("Sheet1")
dat = Mid(Trim(C(7, 0)), 11, 10)
'If h < 1 Then Exit Sub
If IsDate(dat) Then C(6, -3).Resize(h) = CDate(dat)
C(6, -2).Resize(h) = C(2)
C(6, -3).Resize(h, 2).HorizontalAlignment = xlCenter 'centrage
End With
End Sub
'***********************************************

Salut jm.andryszak, l'expérience a été faite et ça marche bien aussi. La meilleure réponse a été choisie en raison de la tentative répétée de job75 et de ne pas ignorer ma demande. Vraiment merci à tous pour l'aide

job75 · 31 Décembre 2022

Je reste sur ma faim :

job75 à dit:
Par curiosité, à quoi vont vous servir les colonnes A et B ?

Dadi147 · 31 Décembre 2022

job75 à dit:
Je reste sur ma faim :

Exactement la même idée. J'essaie d'implémenter la même chose maintenant sur un fichier similaire qui ne diffère que par l'emplacement de la cellule d'adresse. J'avais honte de demander de l'aide à nouveau. Je sens que je vous ai dérangé avec moi. Vraiment, merci Vous m'avez sauvé du problème de copier des lignes à chaque fois.

XL 2016 Extrayez les dates des factures et recopiez-les sur la dernière ligne de la facture vba

Dadi147

XLDnaute Occasionnel

Pièces jointes

job75

job75

XLDnaute Barbatruc

Dadi147

XLDnaute Occasionnel

Pièces jointes

jm.andryszak

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Dadi147

XLDnaute Occasionnel

Dadi147

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

Dadi147

XLDnaute Occasionnel

Discussions similaires