demande d'aide pour modification d'une macro

Version imprimable

Bonjour

J'ai un souci pouvez vous m'aider?

Moi ce que je voulais c’était que s’il y avait ne serait ce qu’une info dans (c9 :c1000) que la macro me restitue les données en D et ainsi de suite

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
'Restitution des données
    Windows(F1).Activate
    For i = 1 To NbFeuilDep
Debut:
        On Error Resume Next
        If Left(FeuilDep(i), 4) = "INFO" Then GoTo Suivant
        For j = 1 To NbLig(i)
            If N°Comm(i, j) = "" Then GoTo Suivant
            Set c = Sheets(FeuilDep(i)).Columns("A").Find(N°Comm(i, j), LookIn:=xlValues)
            If Err.Number = 0 Then
                If Not c Is Nothing Then
                    Dec = 1
                    Do While c.Offset(0, Dec + 1) <> ""
                        Dec = Dec + 1
                    Loop
                    c.Offset(0, Dec + 1) = Abs(Montant(i, j))
                Else
                    Cells([A100000].End(xlUp).Row + 1, 1) = N°Comm(i, j)
                    Cells([A100000].End(xlUp).Row, 2) = NomComm(i, j)
                    Cells([A100000].End(xlUp).Row, 3) = Abs(Montant(i, j))
                End If
            Else
                GoTo CreerFeuille
            End If

Merci de votre aide

29/07/2015, 10h28
Thautheme

Bonjour Personalités, bonjour le forum,

Code incomplet ! Il manque la fin des boucles For : Next i et Next j. Manque les étiquettes Suivant et CreerFeuille.
Il est possible que ce bout de code soit largement suffisant pour t'aider à résoudre ton problème mais je t'avoue que sans avoir une vue d'ensemble j'ai du mal à répondre...

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Option Compare Text
 
 
Sub ImportDonnees()
    Application.ScreenUpdating = False
    Dim i As Integer, j As Integer
    F1 = "fichier d'arrivée.xlsm"
    F2 = "informations de départ.xlsx"
 
'******************************************************************************************
    'Relevé des données
    Windows(F2).Activate
    NbFeuilDep = Sheets.Count
    ReDim FeuilDep(100) As String
    ReDim NbLig(10000) As Long
    ReDim N°Comm(NbFeuilDep, 100000) As String
    ReDim NomComm(NbFeuilDep, 100000) As String
    ReDim Montant(NbFeuilDep, 100000) As Double
 
    For i = 1 To NbFeuilDep
        FeuilDep(i) = Sheets(i).Name
        If Left(FeuilDep(i), 4) <> "INFO" Then
            NbLig(i) = Sheets(FeuilDep(i)).[A100000].End(xlUp).Row
            For j = 1 To NbLig(i)
                N°Comm(i, j) = Sheets(FeuilDep(i)).Cells(j, 3)
                NomComm(i, j) = Sheets(FeuilDep(i)).Cells(j, 4)
                Montant(i, j) = Sheets(FeuilDep(i)).Cells(j, 7)
            Next j
        Else
            N°Comm(i, j) = ""
        End If
    Next i
 
'******************************************************************************************
    'Restitution des données
    Windows(F1).Activate
    For i = 1 To NbFeuilDep
Debut:
        On Error Resume Next
        If Left(FeuilDep(i), 4) = "INFO" Then GoTo Suivant
        For j = 1 To NbLig(i)
            If N°Comm(i, j) = "" Then GoTo Suivant
            Set d = Sheets(FeuilDep(i)).Columns("A").Find(N°Comm(i, j), LookIn:=xlValues)
            If Err.Number = 0 Then
                If Not d Is Nothing Then
                    Dec = 1
                    Do While d.Offset(0, Dec + 1) <> ""
                        Dec = Dec + 1
                    Loop
                    d.Offset(0, Dec + 1) = Abs(Montant(i, j))
                Else
                    Cells([A100000].End(xlUp).Row + 1, 1) = N°Comm(i, j)
                    Cells([A100000].End(xlUp).Row, 2) = NomComm(i, j)
                    Cells([A100000].End(xlUp).Row, 4) = Abs(Montant(i, j))
                End If
            Else
                GoTo CreerFeuille
            End If
        Next j
 
        'Tri sur colonne A
        DerLig = [A8].End(xlDown).Row
        Range("A8:N" & DerLig).Select
        ActiveWorkbook.Worksheets(FeuilDep(i)).Sort.SortFields.Clear
        ActiveWorkbook.Worksheets(FeuilDep(i)).Sort.SortFields.Add Key:=Range("A8:A" & DerLig), _
            SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With ActiveWorkbook.Worksheets(FeuilDep(i)).Sort
            .SetRange Range("A8:N" & DerLig)
            .Header = xlNo
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
Suivant:
    Next i
    Exit Sub
'******************************************************************************************
 
CreerFeuille:
    Sheets.Add
    ActiveSheet.Name = FeuilDep(i)
    [A1] = "Mettre : ""Section""+ nom de l'onglet"
    Range("C6:N6").Value = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
     Range("A7:B7").Value = Array("N°COMMERCIAL", "NOM COMMERCIAL")
    On Error GoTo 0
    GoTo Debut
End Sub

29/07/2015, 11h48
Thautheme

Re,

Du coup c'est ta question que je ne comprends plus ?! Pourquoi la colonne C ?...

Bonjour,

mêmeS remarqueS que Thauthème, le code est difficilement interprétable sur la question que tu poses

je me concentre donc sur la question, qui là encore n'est pas claire, deux interprétations possibles

Citation:

Moi ce que je voulais c’était que s’il y avait ne serait ce qu’une info dans (c9 :c1000) que la macro me restitue les données en D et ainsi de suite

il s'agit donc de regarder si une cellule de la colonne C contient des valeurs (entre la ligne 9 et 1000) ... et si c'est le cas :
1) récupérer la valeur de la cellule située en colonne D et sur la même ligne ?
2) écrire en colonne D la valeur de C quand c'est pas vide ?

un exemple pour le point 1 à totalement adapter, c'est juste la mécanique.
pour le point 2, c'est encore plus simple, et l'exemple ci-dessous (basé sur le point 1) est très facilement adaptable à cette situation
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 Sub ioi() Dim Tableau() Dim i As Long ' transmet la plage C9:D1000 à un tableau VBA Tableau = Feuil1.[C9:D1000].Value ' on affiche le nombre de cellules non vides de la colonne C MsgBox Application.WorksheetFunction.Count(Tableau, 1) ' inspection de toutes les valeurs de la colonne C For i = LBound(Tableau, 1) To UBound(Tableau, 1) ' écrire la valeur de la colonne D si la colonne C n'est pas vide ' on écrit le résultat dans la fenêtre d'execution If Tableau(i, 1) <> "" Then Debug.Print "Données en C" & i + 8 & " || Valeur en D" & i + 8 & " : " & Tableau(i, 2) Next i End Sub

29/07/2015, 14h58
personalités

4 pièce(s) jointe(s)

Bonjour

Merci de votre aide
je me rends compte que je me suis très mal expliqué :
alors je me permets de joindre des PJ à ma demande :

Pièce jointe 184213
Pièce jointe 184214

1 pièce(s) jointe(s)

Bonsoir le fil, bonsoir le forum,

Pas sûr d'avoir bien compris mais voici une proposition en pièce jointe avec le code ci-dessous appliqué au bouton Dispatching :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Option Explicit 'oblige a déclarer toutes les variables
 
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim O As Worksheet 'déclare la variable O (Onglets)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
 
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA du classeur destination (à adapter éventuellement)
On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
Set CD = Workbooks("fichier d'arrivée.xlsx") 'définit le classeur destination CD (génère une erreur si ce classeur n'est pas ouvert)
If Err <> 0 Then 'condition : si une erreur a été générée
    Err.Clear 'efface l'erreur
    Workbooks.Open CA & "fichier d'arrivée.xlsx" 'ouvre le classeur "fichier d'arrivée.xlsx"
    Set CD = ActiveWorkbook 'définit le classeur destination CD
End If 'fin de la condition
On Error GoTo 0 'annule la gestion des erreurs
For Each O In CS.Sheets 'boucle sur tous les onglets O du classeur source CS
    If Not O.Name = "INFO " Then 'condition 1 : si le nom de l'onglet O n'est pas "INFO " (attention il y a un espace à la fin ???)
        Set OS = O 'définit l'onglet source OS
        Set PL = OS.Range("A1").CurrentRegion 'définit la plage PL
        Set PL = PL.Resize(PL.Rows.Count, PL.Columns.Count + 3) 'redéfinit la plage PL (en ajoutant les colonnes E, F et G)
        TC = PL 'définit le tableau de cellules TC
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        Set OD = CD.Sheets(O.Name) 'définit l'onglet de destination OD (génère une erreur si c'est onglet n'existe pas)
        If Err <> 0 Then 'condition 2 : si une erreur a été générée
            Err.Clear 'efface l'erreur
            CD.Sheets.Add After:=CD.Sheets(CD.Sheets.Count) 'ajoute un onglet en dernière position
            ActiveSheet.Name = O.Name 'renomme l'onglet
            Set OD = ActiveSheet 'définit l'onglet de destination OD
            OD.Range("A1").Value = "Section " & OD.Name 'Écrit en A1
            'écrit les mois à partir de C6
            OD.Range("C6").Resize(1, 12) = Array("Janvier", "Février", "Mars", "Avril", "Mai", "Juin", "Juillet", "Août", "Septembre", "Octobre", "Novembre", "Décembre")
            OD.Range("A7").Value = "N° COMMERCIAL" 'écrit en A7
            OD.Range("B7").Value = "NOM COMMERCIAL" 'écrit en B7
            Set DEST = OD.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0) 'définit la cellule de destination DEST
            DEST.Resize(UBound(TC, 1)).Value = Application.Index(TC, , 3) 'récupère dans DEST la troisième colonne de TC
            'récupère dans DEST décalée du'une colonne à droite la quatrième colonne de TC
            DEST.Offset(0, 1).Resize(UBound(TC, 1)).Value = Application.Index(TC, , 4)
        End If 'fin de la condition 2
        On Error GoTo 0 'annule la gestion des erreurs
        Set DEST = OD.Cells(8, Application.Columns.Count).End(xlToLeft).Offset(0, 1) 'définit/redéfinit la cellule de destination DEST
        DEST.Resize(UBound(TC, 1)).Value = Application.Index(TC, , 7) 'renvoie dans DEST les derniers prix enregistrés
    End If 'fin de la condition 1
Next O 'prochain onglet de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissement d'ecran
End Sub