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

Dadi147

XLDnaute Occasionnel
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

Capture.PNG
 

Pièces jointes

  • TEST.xlsm
    24 KB · Affichages: 7
Solution
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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 ?
 

Pièces jointes

  • TEST1.xlsm
    28.7 KB · Affichages: 10

jm.andryszak

XLDnaute Occasionnel
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

XLDnaute Barbatruc
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+
 

Dadi147

XLDnaute Occasionnel
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

XLDnaute Occasionnel
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
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 010
Membres
101 866
dernier inscrit
XFPRO