XL 2016 Incrémentation de valeur avec VBA

yapad05 · 13 Avril 2022

Bonsoir à Tous!

J'ai vraiment besoin d'aide.

J'ai un code VBA qui me permet d'ouvrir plusieurs classeurs, de copier certaines valeurs que je dois normalement coller dans un autre classeur.

Le probleme c'est qu'il n'incrimente pas les valeurs copier. Elles restent toujours à la meme cellule.

Au fait je recois des rapports journaliers que je dois compiler et analyser.

Je vous met le code :

Sub data_base()

Dim wbRecap As Workbook

Dim wsRecap As Worksheet

Dim wbSource As Workbook

Dim wsSource As Worksheet

Dim derlign As Integer

Dim vfichier As Variant

Dim i As Integer, k As Integer

Dim rgrecap As Range

Set wbRecap = ThisWorkbook

Set wsRecap = wbRecap.Sheets(2)

vFichiers = Selectionner_Fichiers(" ")

If Not IsArray(vFichiers) Then

Debug.Print "Aucun fichier sélectionné."

MsgBox "erreur! Aucun/Mauvais fichier sélectionné."

Exit Sub

End If

On Error Resume Next

Application.ScreenUpdating = False

For k = 1 To UBound(vFichiers)

Application.StatusBar = ">> Lecture du fichier #" & k & "/" & UBound(vFichers)

Set wbSource = Workbooks.Open(vFichiers(k))

Set wsSource = wbSource.Sheets(1)

DernLign = wsRecap.Range("A65000").End(xlUp).Offset(1, 0)

wsRecap.Range("C3").Offset(1, 0).Value = wsSource.Range("G18").Value

wbSource.Close

Set wbSource = Nothing

Next k

Application.ScreenUpdating = True
Application.StatusBar = False

End Sub

Function Selectionner_Fichiers(sTitre As String) As Variant

Dim sFiltre As String, bMultiSelect As Boolean

sFiltre = "Fichiers XYZ (.xls)(.xlsm), *.xls*"
bMultiSelect = True

Selectionner_Fichiers = Application.GetOpenFilename(Filefilter:=sFiltre, Title:=sTitre, MultiSelect:=bMultiSelect)

End Function

sylvanu · 16 Avril 2022

Bonsoir, et merci, c'est sympa. C'est quand même plus simple.
En fait l'erreur vient du fait que le mécanisme utilisé avant ( sans ranger par lignes datées ) n'est plus utilisable en l'état.
Avant :

VB:

.Cells(DL+k, "B") = T352(1, 1)

car on rangeait les infos les unes en dessous des autres. D'où l'indice k=1,2,3 ...
Maintenant on indexe par rapport à la date en colonne A, donc l'indice k ne doit plus entrer en ligne de compte. et cela se simplifie :

Code:

'Compressor A
        With Sheets("A")
            .Select
            DL = Application.Match(CLng(DateV4), .Range("A:A"), 0)      ' Où est la date
            If Not IsError(DL) Then                                     ' Si pas de date trouvée, message d'erreur...

sylvanu · 13 Avril 2022

Bonjour Yapad, et bienvenu sur XLD,
Utilisez les balises </> ( à droite de l'icone GIF ) pour le code, c'est franchement plus lisible :

VB:

Sub data_base()
    Dim wbRecap As Workbook
    Dim wsRecap As Worksheet
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim derlign As Integer
    Dim vfichier As Variant
    Dim i As Integer, k As Integer
    Dim rgrecap As Range
    Set wbRecap = ThisWorkbook
    Set wsRecap = wbRecap.Sheets(2)
    vFichiers = Selectionner_Fichiers(" ")
    If Not IsArray(vFichiers) Then
        Debug.Print "Aucun fichier sélectionné."
        MsgBox "erreur! Aucun/Mauvais fichier sélectionné."
.....

et donnez nous un petit fichier test, ce sera plus simple pour trouver une solution.

yapad05 · 13 Avril 2022

sylvanu à dit:
Bonjour Yapad, et bienvenu sur XLD,
Utilisez les balises </> ( à droite de l'icone GIF ) pour le code, c'est franchement plus lisible :

VB:

Sub data_base() Dim wbRecap As Workbook Dim wsRecap As Worksheet Dim wbSource As Workbook Dim wsSource As Worksheet Dim derlign As Integer Dim vfichier As Variant Dim i As Integer, k As Integer Dim rgrecap As Range Set wbRecap = ThisWorkbook Set wsRecap = wbRecap.Sheets(2) vFichiers = Selectionner_Fichiers(" ") If Not IsArray(vFichiers) Then Debug.Print "Aucun fichier sélectionné." MsgBox "erreur! Aucun/Mauvais fichier sélectionné." .....

et donnez nous un petit fichier test, ce sera plus simple pour trouver une solution.

Bonjour Sylvanu

merci pour l'intéret porté à mon égard.

Je te mets les fichier en piece jointe.

Les fichiers test report sont les fichiers recu chaque jour.

je veux creer une macro pour les compiler selon les dates de reception.

Pour les balises je ne comprends pas mais je vais voir comments les autres le fond

merci

sylvanu · 13 Avril 2022

Re,
[Edit] J'ai modifié la PJ suite à un bug trouvé.
Je pense que l'erreur vient de cette ligne :

VB:

wsRecap.Range("C3").Offset(1, 0).Value =

L'offset étant constant, il n'y a aucune raison que le N° de ligne change.
Il faut simplement l'indexer sur k avec :

Code:

wsRecap.Range("C3").Offset(k-1, 0).Value =

NB:
1- J'ai remis le code "à ma sauce" pour comprendre. Sorry.
2- J'ai rajouté un Application.DisplayAlerts = True car à chaque ouverture de fichier il y a un message d'alerte concernant les données externes. Avec ça, plus de message.

A tester car je ne suis pas sur du résultat désiré, mais au moins là ça ne bugue plus, ça remonte bien la valeur.

yapad05 · 14 Avril 2022

Bonjour Sylvanu!

merci bien apparament le code marche corectement, tu es un ange

Mais il continue à m'envoyer les messages d'alerte sur les liaisons du fichier

sylvanu · 14 Avril 2022

Bonjour,
C'est bizarre, sur mon PC, cela a résolu le problème.
Tentez ceci :
1- Dans le fichier faire Options XL/Options avancées
2- Décochez dans Général : Confirmation de la mise à jour automatique des liens

yapad05 · 15 Avril 2022

Merci Sylvanu

J'ai un autre problème
Lorsque je change la valeur de k dans la fonction offset(k-1,0) les fichiers ne s'ouvrent pas pour décaler les lignes des copies. J'arrive à réaliser les copies seulment si k=1

Vois-tu de quoi je parle?

sylvanu · 15 Avril 2022

Bonjour Yapad,
Qu'entendez vous par "Lorsque je change la valeur de k" ? Car k va de 1 à UBound(vFichiers).

Sur mon PC ça marche bien. J'ai rajouté dans le statusbar la valeur de k. Dans cet exemple j'ai 4 fichiers à traiter, donc k va de 1 à 4 :

yapad05 · 15 Avril 2022

Je comprends

Au fait ce que je voudrais c'est la possibilité de pouvoir décaler les copies avec offset dans le fichier test recap.
C'est à dire pouvoir coller les cellules copiers à partir de n'importe quelle que j'aurai choisi.

Est ce possible de faire cela ?

sylvanu · 15 Avril 2022

Re,
k donne l'indice du fichier à traiter, donc on ne doit pas y toucher.
Pour changer l'offset il faut jouer sur le -1 dans Offset(k - 1, 0). Sachant que vous partez de 3 avec C3.
Avec -1 vous partez en C3 car qd k=1, k-1=0 donc offset nul.
Si vous voulez partir en ligne 10 faites k+6 car si k=1 alors Ligne=3+1+6: Range("C3").Offset(k + 6, 0)

yapad05 · 15 Avril 2022

D'accord ça je comprends!

Au fait les rapports viennent chaque jours et j'ai vraiment beaucoup d'information à copier ça me prendrait un temps fou si je devait chaque matin changer la valeur de k. Je t'envoie le fichier avec les code pour que tu es un appercu de quoi je parle

sylvanu · 15 Avril 2022

Re,
Rien compris, déjà les 4 lignes DernLigne s'écrasent les unes les autres. Ensuite je ne vois pas la logique d'aller chercher la dernière ligne de A puisque c'est le 31/12.
Un essai qui pourra peut être vous inspirer, sans vouloir aller plus loin.
Je ne traite dans l'ex que Compressor A avec :

VB:

    For k = 1 To UBound(vFichiers)
        Application.StatusBar = ">> Lecture du fichier #" & k & "/" & NbFiles & "    k = " & k
        Set wbSource = Workbooks.Open(vFichiers(k))
        Set wsSource = wbSource.Sheets(1)
        'Lecture données et rangement dans array
        T352 = wsSource.Range("D352:X352") ' Transfert D352:X352 dans tableau T352
        T353 = wsSource.Range("D353:X353") ' idem pour ligne 353
        T354 = wsSource.Range("D354:X354")
        T355 = wsSource.Range("D355:X355")
        wbSource.Close                  ' Ferme fichier
        Set wbSource = Nothing
        'Compressor A
        With Sheets("A")
            .Select
            DL = .Range("A65000").End(xlUp).Row ' Dernière ligne colonne A
            If DL < 4 Then DL = 3
            .Cells(DL + k, "A") = Now           ' Inscription de la date
            .Cells(DL + k, "B") = T352(1, 1)       ' Transfert tableau
            .Cells(DL + k, "C") = T352(1, 4)
            .Cells(DL + k, "D") = T352(1, 8)
            .Cells(DL + k, "E") = T352(1, 10)
            .Cells(DL + k, "F") = T352(1, 12)
            .Cells(DL + k, "G") = T352(1, 15)
            .Cells(DL + k, "H") = T352(1, 18)
            .Cells(DL + k, "I") = T352(1, 21)
        End With
    Next k

J'ouvre le fichier demandé. Je transfert les données dans 4 arrays pour les lignes de 352 à 355.
Je ferme le fichier.
Je met en colonne A la date courante puis le transfert du tableau dans la bonne ligne.

yapad05 · 15 Avril 2022

sylvanu à dit:
Re,
Rien compris, déjà les 4 lignes DernLigne s'écrasent les unes les autres. Ensuite je ne vois pas la logique d'aller chercher la dernière ligne de A puisque c'est le 31/12.
Un essai qui pourra peut être vous inspirer, sans vouloir aller plus loin.
Je ne traite dans l'ex que Compressor A avec :

VB:

For k = 1 To UBound(vFichiers) Application.StatusBar = ">> Lecture du fichier #" & k & "/" & NbFiles & " k = " & k Set wbSource = Workbooks.Open(vFichiers(k)) Set wsSource = wbSource.Sheets(1) 'Lecture données et rangement dans array T352 = wsSource.Range("D352:X352") ' Transfert D352:X352 dans tableau T352 T353 = wsSource.Range("D353:X353") ' idem pour ligne 353 T354 = wsSource.Range("D354:X354") T355 = wsSource.Range("D355:X355") wbSource.Close ' Ferme fichier Set wbSource = Nothing 'Compressor A With Sheets("A") .Select DL = .Range("A65000").End(xlUp).Row ' Dernière ligne colonne A If DL < 4 Then DL = 3 .Cells(DL + k, "A") = Now ' Inscription de la date .Cells(DL + k, "B") = T352(1, 1) ' Transfert tableau .Cells(DL + k, "C") = T352(1, 4) .Cells(DL + k, "D") = T352(1, 8) .Cells(DL + k, "E") = T352(1, 10) .Cells(DL + k, "F") = T352(1, 12) .Cells(DL + k, "G") = T352(1, 15) .Cells(DL + k, "H") = T352(1, 18) .Cells(DL + k, "I") = T352(1, 21) End With Next k

J'ouvre le fichier demandé. Je transfert les données dans 4 arrays pour les lignes de 352 à 355.
Je ferme le fichier.
Je met en colonne A la date courante puis le transfert du tableau dans la bonne ligne.

Comme les fichiers sont assez confidentiel je ne peux pas les partager, sinon dans le fichier source tu as des cellule fusionner ce qui complique un peu les choses.
Mais si vous le permettez j'ai une dernière question qui pourrait certainement m'aider.
Est il possible de réaliser l'instruction suivante ?
Si la date de la cellule V4 du fichier source est identique à une des dates de la colonne (A) du fichier destinataire alors, commence à coller à partir de cette ligne.

Par exemple si la date du fichier source correspond à la cellule A30 du fichier destinataire colle à partir de la colonne B de la ligne 30 du fichier destinataire.

J'espère que clair ?

sylvanu · 15 Avril 2022

yapad05 à dit:
j'ai une dernière question

C'eut été plus simple de mettre tout dans le même post. Le goutte à goutte oblige à tout reprendre en permanence.
Donc la dernière réponse en PJ, j'ai rajouté le compressor B et :

VB:

DateV4 = wsSource.Range("V4")       ' Acquisition de la date.

et

'Compressor B
        With Sheets("B")
            .Select
            DL = Application.Match(CLng(DateV4), .Range("A:A"), 0) - 1  ' Où est la date
            If Not IsError(DL) Then                                     ' Si pas de date trouvée, message d'erreur
                .Cells(DL + k, "B") = T353(1, 1)    ' Transfert tableau
                .Cells(DL + k, "C") = T353(1, 4)
                .Cells(DL + k, "D") = T353(1, 8)
                .Cells(DL + k, "E") = T353(1, 10)
                .Cells(DL + k, "F") = T353(1, 12)
                .Cells(DL + k, "G") = T353(1, 15)
                .Cells(DL + k, "H") = T353(1, 18)
                .Cells(DL + k, "I") = T353(1, 21)
            Else
                MsgBox "La date n'appartient pas au fichier."
            End If
        End With

cp4 · 15 Avril 2022

yapad05 à dit:
Comme les fichiers sont assez confidentiel je ne peux pas les partager

Bonjour @yapad05 , @sylvanu ,

Je partage les avis de Sylvanu.
@yapad05 : Tu peux prendre une copie de ton fichier et 'crypter' tes données confidentielles.
C'est ce que je fais en utilisant "rechercher et remplacer". Exemple: Dupond est confidentiel, je le remplace par Dp et le tour est joué.
Évite aussi les cellules fusionnées.

A+

XL 2016 Incrémentation de valeur avec VBA

yapad05

XLDnaute Nouveau

sylvanu

sylvanu

XLDnaute Barbatruc

yapad05

XLDnaute Nouveau

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

yapad05

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

yapad05

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

yapad05

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

yapad05

XLDnaute Nouveau

Pièces jointes

sylvanu

XLDnaute Barbatruc

Pièces jointes

yapad05

XLDnaute Nouveau

sylvanu

XLDnaute Barbatruc

Pièces jointes

cp4

XLDnaute Barbatruc

Discussions similaires