XL 2016 Incrémentation de valeur avec VBA

yapad05

XLDnaute Nouveau
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
 
Solution
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

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

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

Pièces jointes

  • 01 Jan test Report.xls
    636.5 KB · Affichages: 4
  • 02 Jan test Report.xls
    636.5 KB · Affichages: 3
  • 03 Jan test Report.xls
    636.5 KB · Affichages: 2
  • 04 Jan test Report.xls
    636.5 KB · Affichages: 2
  • test_recap.xlsx
    34.9 KB · Affichages: 2

sylvanu

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • test_recap.xlsm
    44 KB · Affichages: 2
Dernière édition:

sylvanu

XLDnaute Barbatruc
Supporter XLD
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
1649924254330.png
 

yapad05

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

yapad05

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

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

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

Pièces jointes

  • Baobab.xlsm
    696.5 KB · Affichages: 3

sylvanu

XLDnaute Barbatruc
Supporter XLD
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.
 

Pièces jointes

  • test_recap2.xlsm
    57.3 KB · Affichages: 0

yapad05

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

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

Pièces jointes

  • test_recap3.xlsm
    72.9 KB · Affichages: 2

cp4

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

Discussions similaires

Statistiques des forums

Discussions
311 721
Messages
2 081 928
Membres
101 842
dernier inscrit
seb0390