Résultats pour "iserror vba"

8'717 résultats pour cette recherche

Bonjour,

Je débute sur VBA et je bloque sur le problème suivant. Je souhaiterais que les champs ci dessous soient renseignés par des commentaires et la date du jour, dés que le message #N/A apparaît au niveau de Range("P3:P300")

Range("S3:S300").Value = "En attente"

Range("T3:T300").Value = Date

Range("W3:W300").Value = "A valider"

Dans un premier temps j'ai voulu remplacer le message d'erreur #N/A par 0 ou bien par NA en utilisant les deux procédures suivantes, sans succés :

'If IsError(Range("P3:P300")) Then Range("P3:P300").Value = 0

ou bien

'If WorksheetFunction.IsNA(Range("P3:P300")) = True Then Range("P3:P300") = "NA"

Dans un deuxième temps, j'ai voulu que les champs mentionnés précédemment soient remplis avec les commentaires en utilisant ces deux autres formules :

'If IsError(Range("P3:P300").Value) Then

ou bien

'If Range("P3:P300") = CVErr(xlErrNA) Then

Range("S3:S300").Value = "En attente"

Range("T3:T300").Value = Date

Range("W3:W300").Value = "A valider"

End If

Merci d'avance pour votre aide.

Bonjour,

Je sollicite votre aide car je rencontre un soucis avec cette macro :

For Each c In Sheets("Barquette").Range("B6,B12,B18,B30,B40,B46,B52,B63,Q6,Q12,Q18,Q30,Q40,Q46,Q52,Q53")
If IsError(c) Then MsgBox "Attention, il y a une anomalie dans le menu! Veuillez corriger les erreurs avant de poursuivre l'impression", vbExclamation
Next
UserForm4.Show

Je souhaiterais que la macro n'ouvre pas userform si une erreur est détecté.

Merci par avance pour votre aide

Bonjour à tous,

Cela fait un moment que je galère avec ce morceau de code qui me renvoi une erreur 1004 lorsque la valeur de la cellule n'est pas trouvé dans le tableau de la "Feuil2" :

Sub Mise_A_Jour()

Dim Cell As Range

Range("c11:cd24").Select

For Each Cell In Selection

If IsError(WorksheetFunction.VLookup(Cell.Value, Sheets("feuil2").Range("b7:cm350"), 4, False))= true then _

msgbox "Pas trouvé" else msgbox "ok"

Next

End sub

Est ce que quelqu'un aurait un code magique?? lol

Merci d'avance

Bonjour voici mon code,

Sub copydatabis()
Dim Nom As Variant
Dim NomStk(), SerieDate()

'Suppression des noms des plages
    For Each Nom In ActiveWorkbook.Names
        If Nom.Name = "Stocks" Or Nom.Name = "DateDeb" Or Nom.Name = "DateFin" Then
            Nom.Delete
        End If
    Next

'Réinitialisation des plages Nom
    ActiveWorkbook.Names.Add Name:="Stocks", RefersToR1C1:="=offset('Sheet1'!R4C1,1,,counta('Sheet1'!C1)-3,1)"
    ActiveWorkbook.Names.Add Name:="DateDeb", RefersToR1C1:="=R1C2"
    ActiveWorkbook.Names.Add Name:="DateFin", RefersToR1C1:="=R2C2"

NbDate = Range("DateFin").Value - Range("DateDeb").Value + 1
NbStocks = Range("Stocks").Rows.Count

    ActiveWorkbook.Names.Add Name:="Quotation", RefersToR1C1:="=offset('Sheet1'!R4C3,,,NbDate,NbStocks*2)"

'Initialisation de la variable tableau NomStk
Cmpt = 0
For Each cell In Range("Stocks").Cells
    ReDim Preserve NomStk(Cmpt)
    NomStk(Cmpt) = cell.Value
    Cmpt = Cmpt + 1
Next cell

'Initialisation de la variable tableau NomRef
Cmpt = 0
ReDim NomRef(UBound(NomStk, 1))
For i = 0 To UBound(NomStk, 1)
    NomRef(i) = Range("Stocks").Cells(i + 1).Offset(0, 1).Value
Next i

'Initialisation de la série des dates jours ouvrés
Cmpt = 0
For i = Range("DateDeb").Value To Range("DateFin").Value
    If WorksheetFunction.Weekday(CDate(i) < 7) Or WorksheetFunction.Weekday(CDate(i) > 1) Then
        ReDim Preserve SerieDate(Cmpt)
        SerieDate(Cmpt) = CDate(i)
        Cmpt = Cmpt + 1
    End If
Next i

'Compte le nombre de valeur <> "" dans le vecteur NomRef
Cmpt = 0
For i = 0 To UBound(NomRef)
    If NomRef(i) <> "" Then Cmpt = Cmpt + 1
Next i

'Initialisation de la table des résultats
ReDim Returns(UBound(SerieDate), UBound(NomStk) - Cmpt)

'Resultats

For i = 0 To UBound(SerieDate)
    For j = 0 To UBound(NomStk)
        Cmpt = 0
        For k = 0 To UBound(NomRef)
            If NomStk(j) = NomRef(k) Then Cmpt = Cmpt + 1
        Next k
        If NomRef(j) = "" And Cmpt = 0 Then
            If WorksheetFunction.IsErr(WorksheetFunction.Match(SerieDate(i), Range("Quotation").Resize(, j * 2 + 1), 0)) = False Then
                LigStk = WorksheetFunction.Match(SerieDate(i), WorksheetFunction.Index(Range("Quotation"), 0, j * 2 + 1), 0)
                Returns(i, j) = WorksheetFunction.Index(Range("Quotation"), LigStk, j * 2 + 2)
            Else
                Returns(i, j) = 0
            End If
        Else
            DateLunch = WorksheetFunction.Index(Range("Quotation"), 1, j * 2 + 1)
            RetStk = WorksheetFunction.Index(Range("Quotation"), 1, j * 2 + 2)
            For k = 0 To UBound(NomStk)
                If NomRef(j) = NomStk(k) Then ColRef = k
            Next k
            LigRef = WorksheetFunction.Match(DateLunch, WorksheetFunction.Index(Range("Quotation"), 0, ColRef * 2 + 1), 0)
            RetRef = WorksheetFunction.Index(Range("Quotation"), LigRef, ColRef * 2 + 2)
            LigRef = WorksheetFunction.Match(SerieDate(i), WorksheetFunction.Index(Range("Quotation"), 0, ColRef * 2 + 1), 0)
             Returns(i, j) = RetSk / RetRef * WorksheetFunction.Index(Range("Quotation"), LigRef, ColRef)
        End If
    Next j
Next i

End Sub

Ca bloque a ce niveau la

            If WorksheetFunction.IsErr(WorksheetFunction.Match(SerieDate(i), Range("Quotation").Resize(, j * 2 + 1), 0)) = False Then

Ci-joint le lien du fichier: https://docs.google.com/open?id=0B1XYA-Rihjk3OGJzNWFJYktRb0E

Pourriez vous m'aider?

Je vous remercie!!

Bonjour à tous !

Voici la formule que j'ai créé sur feuil1, rattachée une base de données en feuil2.

=IF((A11=""),"",VLOOKUP($C$2,Commercial!$A$2:$E$178,2,FALSE))

L'objectif est de rechercher pour la valeur A11 non nul, les valeurs relatives en feuil2.

Question : comment inclure la fonction ISERROR dans cette formule pour que la recherche ne me retourne pas un #N/A si aucune valeur n'est associée (mais plutôt une cellule vide ?

Merci par avance pour vos réponses toujours appréciées !

Bonsoir,

Je sais qu'il y a beaucoup plus simple (notamment en utilisant une cellule fixe dans le tableau, modifiable par VBA), mais, savez-vous s'il est possible de modifier du code VBA à l'aide d'un autre code VBA.

Par exemple, si j'ai un code simple :

Private Sub CommandButton2_Click()
Cells(9, 8).Value = Cells(6, 6).Value * (50 / 100) * (11.5 / 100)
End Sub

Puis-je agir sur les valeurs 50 / 100 ou 11.5 / 100

Je peux, par exemple, faire apparaître un UserForm, proposant de modifier certaines valeurs fixes qui s'appliquent à de nombreuses cellules dans le tableau. Si j'inscrit 22 dans le premier champ et 17 dans le second j'obtiendrais :

Private Sub CommandButton2_Click()
Cells(9, 8).Value = Cells(6, 6).Value * (22 / 100) * (17 / 100)
End Sub

Et le bouton en question produirait donc un calcul différent.

Bonne soirée !

Bonjour,

Malgré les explications déjà faites sur ce forum, notamment dans ces discussions :

https://forum.excel-pratique.com/viewtopic.php?t=53841

https://forum.excel-pratique.com/viewtopic.php?f=2&t=132483

Je ne parviens pas à faire fonctionner ce code :

Spoiler

où nm et prn = des string ; si nm = "Ti"et prn = "ta" alors le nom de la feuille est "ti_ta"

Sub CreateWsEvenMacro()
Dim a As Integer, b As Integer

'ActiveWorkbook.VBProject.VBComponents.Count

    With ActiveWorkbook(nm & "_" & prn).codeModule
    a = .countOfLines
        .insertLines a + 1, "Private Sub Worksheet_activate()"
        .insertLines a + 2, "Call Decharge_Usf"
        .insertLines a + 3, "Bandeau_actions.Show 0"
        .insertLines a + 4, "End Sub"
    End With
End Sub

Je n'ai pas d'erreur, il ne se passe juste rien car je pense qu'Excel ne trouve pas ce que je cherche.

Le problème vient d'ici :

ActiveWorkbook(nm & "_" & prn).codeModule

Que j'ai également essayé d'écrire :

ActiveWorkbook.VBProject.VBComponents(nm & "_" & prn).codeModule

Ou bien

ActiveWorkbook.VBProject.(nm & "_" & prn).codeModule

Savez-vous ce que je dois écrire pour qu'Excel trouve, dans le document, le nom de la feuille recherchée ?

Cela ne fonctionne pas non plus si je demande à ce qu'Excel génère une feuille toujours nommée "Feuil1", sur laquelle je lancerais la macro ci-après, que je renommerais après.

Mon document est tout imbriqué, alors pour extraire la partie du code qui m'intéresse et proposer un document pour l'exemple ça va me prendre un peu de temps, je vous le transmets dès que possible !

Merci de votre attention !

Bonne soirée

Hello le forum,

je bloque sur un problème ...

J'ai un tableau VBA avec n lignes et 4 colonnes, voici comment je l'alimente :

ReDim Tab_Filtre_Compta(1 To Last_Row_Compta, 1 To 4) 'Redimension le tableau sur 4 colonnes (Account, Débit, Crédit, Team&Emplo)

Compteur_Tab_Compta = 1 'Compteur Tableau
For Ma_Ligne_Affichee = 2 To Last_Row_Compta 'Boucle sur les valeurs des lignes visibles
        'si la ligne n'est pas filtrée alors on alimente notre tableau des valeurs (Account + D + C + CODE)
        If .Rows(Ma_Ligne_Affichee).Hidden = False Then Tab_Filtre_Compta(Compteur_Tab_Compta, 1) = .Cells(Ma_Ligne_Affichee, o): Tab_Filtre_Compta(Compteur_Tab_Compta, 2) = .Cells(Ma_Ligne_Affichee, y): Tab_Filtre_Compta(Compteur_Tab_Compta, 3) = .Cells(Ma_Ligne_Affichee, x): Tab_Filtre_Compta(Compteur_Tab_Compta, 4) = .Cells(Ma_Ligne_Affichee, z) & "_" & .Cells(Ma_Ligne_Affichee, k): Compteur_Tab_Compta = Compteur_Tab_Compta + 1
Next Ma_Ligne_Affichee

Maintenant ce que je veux faire c'est d'avoir une liste sans doublons de la colonne 4 de ce tableau et inscrire cette liste dans une feuille ....

Mon idée est de créer un dico qui va parcourir chaque valeur de ma colonne 4 et si la valeur n'est pas présente dans mon dico, elle est ajoutée ...

Mais à coder c'est une autre histoire

Pourriez-vous me donner un petit coupe de main svp.

Merci à vous.

R@g.

Bonjour,

Aujourd'hui je viens poser une question aux connaisseurs. J'ai une colonne de B1 à B10 avec une mise de forme conditionnelle de type barre de données. Les barres apparaissent en fonction de la valeur en pourcentage qui est inscrite sous ses cases. Je souhaiterai un code VBA qui disent juste que B1=A1, B2=A2,etc...

Comme cela je peux visualiser la valeur en colonne A1:A10 et je peux voir les barres de progression du pourcentage en B1:B10.

ATTENTION : je ne veux pas que "B1.Value=A1.Value" mais je veux inscrire dans B i: "=A i". Je veux pouvoir modifier A et voir mes barres bouger

Bonjour,

Pour une partie du traitement des données sur Excel, j'utilise un code qui met un peu de temps à s'exécuter. Tout est pratiquement terminé et je cherche désormais à optimiser un peu tout ça pour que ça tourne plus vite (notamment sur des machine un peu moins récentes).

Après plusieurs tests, pour 70 lignes le code peut mettre jusqu'à 1min10 à se terminer.

Mais il peut y avoir bien plus de lignes.

Sub 1 (structabBDD) : < 1 sec

Sub 2 (Rechnum) : 13sec30

Sub 3 (structab) : < 1 sec

Sub 4 (CorrCodes) : 54 sec

Sub 5 (style) : 1 sec

Sub 6 (RechErr) : < 1 sec

Comme vous pouvez le constater, le code qui met le plus de temps à s'exécuter est le sub CorrCodes () qui pourtant est très loin d'être le plus complexe !

Voici le code dans son ensemble :

Private Sub CommandButton1_Click() 'KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'If KeyCode = 13 Then CommandButton1_Click

Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")

Dim valtab As Long
valtab = Application.WorksheetFunction.CountBlank(co.Range("A1:J10"))
If valtab < 100 Then Rep = MsgBox("Des données sont déjà présentes dans le tableau, Voulez-vous nettoyer les données ?", vbYesNo + vbExclamation, "Tableau existant")
    If Rep = vbYes Then
        co.Cells.ClearContents
        co.Cells.Interior.ColorIndex = xlColorIndexNone
            structabBDD
            Rechnum
            structab
            CorrCodes
            style
            RechErr
        If Rep = vbNo Then
    structabBDD
    Rechnum
    structab
    CorrCodes
    style
    RechErr
    End If
Else
    structabBDD
    Rechnum
    structab
    CorrCodes
    style
    RechErr
End If

End Sub
Option Explicit

Dim n As String, Rep As Byte
Dim lrfb As Long, lrco As Long, lrsa As Long, lrdc As Long, r As Long
Dim fb As Worksheet, sa As Worksheet, dc As Worksheet, ds As Worksheet, co As Worksheet
Dim rng As Range, cell As Range, rng2 As Range, Cell2 As Range
Dim i&, derLn&, nb&, derLn2&, nb2&
Dim del As Integer

structabBDD

Sub structabBDD()

    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With dc
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Bdd_complète"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Bdd_complete"
        End If
    End With
    With ds
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Bdd_synonymes"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Bdd_synonymes"
        End If
    End With
End Sub

Rechnum

Sub Rechnum()

Set fb = Worksheets("Formulaire bota")
Set sa = Worksheets("Saisie")
Set co = Worksheets("Correspondances")
Set dc = Worksheets("Database complete")
Set ds = Worksheets("Database synonymes complete")

        Dim Lig As Long
        Dim Col As String
        Dim NbrLig As Long
        Dim NumLig As Long

            co.Cells(1, 1).Value = sa.Cells(1, 1).Value
            co.Cells(1, 2).Value = fb.Cells(1, 4).Value
            co.Cells(1, 3).Value = sa.Cells(1, 4).Value
            Cells(1, 4).Value = "Correspondance"
            co.Cells(1, 5).Value = sa.Cells(1, 5).Value
            co.Cells(1, 6).Value = sa.Cells(1, 6).Value
            co.Cells(1, 7).Value = fb.Cells(1, 5).Value
            co.Cells(1, 8).Value = fb.Cells(1, 6).Value
            co.Cells(1, 9).Value = fb.Cells(1, 16).Value
            co.Cells(1, 10).Value = fb.Cells(1, 17).Value
            co.Cells(1, 11).Value = fb.Cells(1, 12).Value
            co.Cells(1, 12).Value = fb.Cells(1, 13).Value

                lrfb = fb.Cells(Rows.Count, 1).End(xlUp).Row
                lrsa = sa.Cells(Rows.Count, 1).End(xlUp).Row

                Dim vari As Range, plge As Range

                'Remplissage de la colonne [A] (Parrent row ID)
                'Remplissage de la colonne [C] (espece)
                     With sa
                        'dernière ligne non vide de la colonne A
                        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row
                        'Plage à copier
                        Set rng = .Cells(1, 1).Resize(lrsa + 1)
                        Set rng2 = .Cells(1, 4).Resize(lrsa + 1)
                    End With

                    With co
                        'dernière ligne non vide de la colonne A
                        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row
                        Set cell = .Cells(lrsa, 1)
                        Set Cell2 = .Cells(lrsa, 3)
                    End With

                    rng.Copy Destination:=cell
                    rng2.Copy Destination:=Cell2

                    With co
                        'dernière ligne non vide de la colonne A
                        lrsa = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
                        'plage de cellules
                        Set rng = .Cells(1, 1).Resize(lrsa - 1)
                        Set rng2 = .Cells(1, 3).Resize(lrsa - 1)
                    End With

                'Remplissage de la colonne [B] (Numéro étude)
                Dim i1 As Integer, num1 As Variant
                With Worksheets("Correspondances")
                lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
                For i1 = 2 To lrco
                On Error Resume Next
                  num1 = Application.WorksheetFunction.VLookup(.Cells(i1, 1), Sheets("Formulaire bota").Range("A:D"), 4, 0)
                  .Cells(i1, 2) = IIf(IsError(num1), 0, num1)
                Next
                End With

                'Conserver les valeurs recherchées (num étude)
                    With co
                        For del = co.Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
                            If .Range("B" & del).Value <> n Then
                            .Rows(del).Delete
                            End If
                        Next del
                    End With

                'Remplissage de la colonne [E] (abondance)
                'Remplissage de la colonne [F] (remarque)
                'Remplissage de la colonne [C] (especes) (désactivé)
                Dim i2 As Integer, num2 As Variant, num3 As Variant, num4 As Variant
                    With Worksheets("Correspondances")
                        lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
                        For i2 = 2 To lrco
                        On Error Resume Next
                            num2 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("saisie").Range("A:E"), 5, 0)
                            .Cells(i2, 5) = IIf(IsError(num2), 0, num2)
                            num3 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("saisie").Range("A:F"), 6, 0)
                            .Cells(i2, 6) = IIf(IsError(num3), 0, num3)
                            'num4 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("saisie").Range("A:D"), 4, 0)
                            '.Cells(i2, 3) = IIf(IsError(num4), 0, num4)
                        Next
                    End With

                'Remplissage de la colonne [G] (cortege)
                'Remplissage de la colonne [H] (autres_infos)
                'Remplissage de la colonne [I] (x)
                'Remplissage de la colonne [J] (y)
                'Remplissage de la colonne [K] (created_date)
                'Remplissage de la colonne [L] (created_user)
                Dim num5 As Variant, num6 As Variant, num7 As Variant, num8 As Variant, num9 As Variant, num10 As Variant

                    With Worksheets("Correspondances")
                        For i2 = 2 To lrco
                        co.Cells(i2, 11).NumberFormat = "dd/mm/yyyy;@"
                        co.Cells(i2, 10).NumberFormat = "General"
                        co.Cells(i2, 2).NumberFormat = "@"

                        On Error Resume Next
                            num5 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:E"), 5, 0)
                            .Cells(i2, 7) = IIf(IsError(num5), 0, num5)
                            num6 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:F"), 6, 0)
                            .Cells(i2, 8) = IIf(IsError(num6), 0, num6)
                            num7 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:G"), 7, 0)
                            .Cells(i2, 11) = IIf(IsError(num7), 0, num7)
                            num8 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:M"), 13, 0)
                            .Cells(i2, 12) = IIf(IsError(num8), 0, num8)
                            num9 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:P"), 16, 0)
                            .Cells(i2, 9) = IIf(IsError(num9), 0, num9)
                            num10 = Application.WorksheetFunction.VLookup(.Cells(i2, 1), Sheets("Formulaire bota").Range("A:Q"), 17, 0)
                            .Cells(i2, 10) = IIf(IsError(num10), 0, num10)
                        Next
                    End With

                'Retirer l'heure de la date
                Dim Nc, Cib As Range
                    For Each Cib In Range("K2:K" & lrco)
                        Cib.Value = Trim(Cib.Value) 'supprime espaces
                        Nc = Len(Cib)               'compte les caractères
                        If Len(Cib.Value) > 10 Then Cib.Value = Left(Cib, Nc - 9)
                    Next Cib

                'Compéter la nouvelle colonne "correspondances"
                Dim ii As Integer, vv As Variant
                    Set dc = Sheets("Database complete")
                    Set ds = Sheets("Database synonymes complete")
                    derLn = dc.Range("A" & Rows.Count).End(xlUp).Row
                    derLn2 = ds.Range("A" & Rows.Count).End(xlUp).Row

                    For ii = 2 To co.Range("A" & Rows.Count).End(xlUp).Row
                    Cells(1, 14).Value = ii
                        nb = WorksheetFunction.CountIfs(dc.Range("A2:A" & derLn), co.Range("C" & ii))
                        nb2 = WorksheetFunction.CountIfs(ds.Range("B2:B" & derLn2), co.Range("C" & ii))
                        If nb = 0 Then
                            If nb2 > 0 Then
                                co.Range("D" & ii) = "Synonymes"
                            ElseIf nb2 = 0 Then
                            co.Range("D" & ii) = "Code erroné"
                            End If
                        ElseIf nb = 2 Then
                            co.Range("D" & ii) = "Codes jumeaux"
                        ElseIf nb = 1 And nb < 2 And nb <> 0 Then
                            On Error Resume Next
                            vv = Application.WorksheetFunction.VLookup(co.Cells(ii, 3), Sheets("Database complete").Range("A:G"), 7, 0)
                            co.Cells(ii, 4) = IIf(IsError(vv), 0, vv)
                        End If
                    Next ii

                Unload UserForm4
End Sub

structab

Sub structab()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim tb As ListObject

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    With co
        If .ListObjects.Count Then
        .ListObjects(1).Name = "Correspondances"
        Else
        Set tb = .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion)
        tb.Name = "Correspondances"
        End If
    End With
End Sub

CorrCodes

Sub CorrCodes()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet
    Dim lrco As Long

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

lrco = co.Cells(Rows.Count, 1).End(xlUp).Row
Dim supspa As Range
    For Each supspa In Sheets("Correspondances").Range("C1:C" & lrco)
        supspa.Value = Trim(supspa.Value) 'RTrim = suppr espace en fin de chaine ; LTrim en début de chaine
    Next supspa

Dim modssp As Long
    For modssp = 2 To lrco
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "subsp.", "ssp.")
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "subsp", "ssp.")
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "..", ".")
        co.Range("C" & modssp) = Replace(co.Range("C" & modssp), "var", "var.")

    Next modssp
End Sub

style

Sub style()
    Dim dc As Worksheet, ds As Worksheet, co As Worksheet

    Set dc = Worksheets("Database complete")
    Set ds = Worksheets("Database synonymes complete")
    Set co = Worksheets("Correspondances")

    Dim a As Integer

        For a = 2 To lrco
            If co.Cells(a, 4) = "Code erroné" Then
                co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(204, 51, 0)
                co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(255, 255, 255)
            Else
                If co.Cells(a, 4) = "Codes jumeaux" Then
                co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(255, 255, 102)
                co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                Else
                    If co.Cells(a, 4) = "Synonymes" Then
                    co.Range(Cells(a, 4), Cells(a, 4)).Interior.Color = RGB(71, 185, 182)
                    co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                    Else
                        If co.Cells(a, 4) <> "Synonymes" Or co.Cells(a, 4) <> "Code erroné" Or co.Cells(a, 4) <> "Codes jumeaux" Then
                        co.Range(Cells(a, 4), Cells(a, 4)).Interior.ColorIndex = xlColorIndexNone
                        co.Range(Cells(a, 4), Cells(a, 4)).Font.Color = RGB(0, 0, 0)
                        End If
                    End If
                End If
            End If
        Next a

End Sub

RechErr

Sub RechErr()

Set co = Worksheets("Correspondances")
lrco = co.Cells(Rows.Count, 1).End(xlUp).Row

    Dim Plageb As Range
    Dim Cibleb, Cible2b, Cible3b
    Set Plageb = co.Range("D1:D" & lrco)
    On Error Resume Next
    Cibleb = Application.WorksheetFunction.CountIf(Plageb, "=Code erroné")
    Cible2b = Application.WorksheetFunction.CountIf(Plageb, "=Codes jumeaux")
    Cible3b = Application.WorksheetFunction.CountIf(Plageb, "=Synonymes")
    If Cibleb + Cible2b + Cible3b > 0 Then UserForm3.Show

End Sub

Je n'ai pas mis mon document Excel, mais si vous jugez que ce serait plus clair de travailler sur un document Excel, alors j'en créerai un plus léger, celui que j'utilise est un peu trop volumineux.

Est-ce que vous pensez qu'il est possible de faire quelque chose qui s'exécute plus vite ?

Je suis curieux aussi de ne plus déclarer les colonnes traitées par leur numéro mais par leur nom, de manière à ce qu'en cas de modification du tableau initial, le code soit capable de s’exécuter encore. Il faut variabiliser le tableau si j'ai bien compris. Je vais regarder ça..

Merci de votre attention

Bonne journée !

Bonjour,

Je recherche à importer des fichiers LOG à la suite dans une même feuille.

J'ai simplement réussi à intégrer dans des feuilles séparées.

Chaque nom de fichier LOG est constitué de sa date de création.

Le nom du fichier devra être intégrer devant l'intégration en colonne A.

Merci beaucoup pour votre aide.

Jonathan

Voici le code que j'ai fait pour le moment :

Sub ImporterLog()

Dim Ligne As String

Dim I As Long

Dim Hier As Date

Dim fichier As String

Jmoins0 = Date

fichier = "C:\Users\jonat\AppData\Roaming\Logs\" & Format$(Jmoins0, "yyyymmdd") & ".log"

'adapter le chemin

Open fichier For Input As #1

Do While Not EOF(1)

Line Input #1, Ligne

I = I + 1

Cells(I, 1) = Ligne

Loop

Close #1

End Sub

Bjr monsieur

je souhaiterai votre aide sur un sujet qui me fatigue beaucoup

quand je programme logiciel sur vba excel 2010, il ne fonctionne pas sur excel 2013.

quels sont les raisons de cela?

Bonjour le forum,

Voici le premier message que je poste, étant tout nouveau membre. ,

Je suis bloqué sur une ligne d'une procédure qui crée et manipule un Worksheet qui est la suivante :

ThisWorkbook.Worksheets(Nom_Onglet).Parent.VBProject.VBComponents(Worksheets(Nom_Onglet).CodeName).Properties("_CodeName") = Nouveau_Nom_Onglet

Ce qui se passe concrètement, c'est que les Userform qui étaient affichées disparaissent, exactement comme si je cliquais sur le bouton STOP de l'éditeur de Visual Basic (sauf que les lignes de codes qui suivent sont bien exécutées, donc ce n'est pas le bouton STOP).

Je suppose que ceci est dû à la manipulation du VBA par code...?

Après faire des essais pour chercher à comprendre le comportement de VBA, je confirme qu'il ne s'agit pas d'une fermeture du formulaire (les événements QueryClose et Terminate de l'Userform ne sont pas détectés). En revanche c'est exactement le même comportement qui se produit si je clique sur le bouton STOP de Visual Basic ("Réinitialiser").

Auriez-vous déjà rencontré ce phénomène et existe-t-il une solution pour l'éviter, et ainsi conserver les Userform chargée ?

Je précise qu'à part ce phénomène, la procédure fonctionne sans planter, et que le résultat est bon. L'ennui c'est uniquement ce qui se passe avec cette fermeture de Userform...

Merci par avance,

PE

Bonsoir,

je cherche à remplir un tableau sous VBA à deux dimension par l'intermédiaire d'un tableau VBA à une dimension.

J'imagine une boucle, à la première rotation les deux tableaux ont la même taille, mais à partir de la deuxième rotation, le deuxième tableau acquière sa deuxième dimension, afin de se retrouver avec un tableau représentant une plage à deux dimension.

Le premier tableau est une récupération de 5 valeurs se trouvant sur une ligne allant de la colonne B à F

Sur le fichier joint, ces lignes sont les unes sous les autres mais en fait dans la réalité c'est la même ligne, mais des calculs interviennent entre temps et la ligne de valeurs change à chaque rotation...

En J14 le transfert du tablo1, ceci fonctionne, à chaque tour il y a bien les nouvelles valeurs.

En J15 et lignes inférieures, on devrait retrouver un équivalent de la zone des colonnes B à J.

Comment faut-il faire ?

Le passage par le premier tableau Est-ce une bonne idée ?

Ne faut-il pas prendre les données directement sur la feuille pour les mettre dans le tablo2 ?

En plus je m'aperçois que les données source ne sont pas en ligne mais en colonne, par contre le résultat sera en ligne lors du ransfert du tablo2 sur la feuille, à quel moment utiliser le "transpose" ?

Merci par avance.

Le fichier :

@ bientôt

LouReeD

Bonjour,

J'ai un code VBA (que je n'ai pas réalisé personnellement) qui fonctionne très bien sur un fichier mais quand je copie/colle la macro sur un autre fichier, ça ne fonctionne pas.

La macro est inscrite dans le code de la feuille. Elle s'applique donc dès que j’écris dans une cellule.

Elle a pour but de Colorier soit en Bleu ou soit en Orange une plage de cellule, suivant que le mois soit pair ou impair.

Elle met également en majuscule tout les données inscrite sur trois colonnes différentes.

Je ne comprend vraiment pas pourquoi elle ne fonctionne pas dans l'autre fichier car ils sont semblable.

Si vous pouvez m'éclairer sur les raisons possibles ?

Ou alors me traduire les formules présente dans le code, que j'ai dû mal à comprendre.

Dim NumVals As Long

Private Sub Worksheet_Change(ByVal Target As Range)
Dim oRange As Range
Dim NewCount As Long
Dim i As Long
Dim j As Long

If Target.Row < 3 Then Exit Sub
If Intersect(Target, Range("B3:H500")) Is Nothing Then Exit Sub
On Error GoTo Lig1

    i = Target.Row
    j = Target.Column

    NewCount = Application.WorksheetFunction.CountA(Target)

    If NewCount = 0 And NumVals > 0 Then
        Range(Cells(i, "B"), Cells(i, "H")).Interior.Pattern = xlNone
        Exit Sub
    End If

Application.EnableEvents = False
    Select Case j
      Case 2
        Set oRange = ActiveSheet.Range(ActiveSheet.Cells(Target.Row, Target.Column), ActiveSheet.Cells(Target.Row, 8))
        If IsDate(Target.Value) Then
          ColorLigne oRange
        Else
          oRange.Interior.Pattern = xlNone
        End If
     Case 3, 4, 8
        Target = UCase(Target)
    End Select
Lig1:
Application.EnableEvents = True

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    NumVals = Application.WorksheetFunction.CountA(Target)
End Sub

Cordialement,

Antho-

Bonjour,

Je voudrais tester de créer une macro mais j'ai du mal avec le code VBA et je voudrai traduire ce code mi-VBA mi-Excel en quelque chose qui marche correctement.

i = 4
o = 2
Tant que Valeur de la Cellule (ligne 2;colonne o) <> ""
   Tant que Valeur de la Cellule (ligne i; colonne 2) <> ""
      Si Valeur de la Cellule (i;2) > 1
         a = Ligne(index(G4:H5;Equiv(Cellule(i;1);G4:H5))) + 1
              Tant que Valeur Cellule (a;6) <> ""
                   Si Valeur Cellule (a;6) = "OUV"
                       b = Ligne(index(G4:H5;Equiv(Cellule(a;5);G4:H5))) + 1
                          Tant que Valeur Cellule (b;6) <> ""
                               Si Cellule(a;6) = Cellule (2;0)
                                      Cellule (i;o) = 3
                               Sinon b = b + 1
                    Sinon a = a + 1
      Sinon i = i + 1
o = o + 1

En réalité elle n'est pas vraiment fini mais déjà de traduire ça en VBA m'aiderait grandement !

Cordialement,

Antho-

Bonsoir

J'ai un fichier sur lequel j'ai ajouté un code VBA pour détecter un doublon, seulement celui ci ne fonctionne pas correctement.

J'ai également un soucis concernant une sélection multiple de valeurs...

Bref tout ça expliquer dans mon dossier

Bonne soirée et merci

M07

Hello tout le monde,

j'ai ce petit bout de macro que j'utilise pour filtrer des lignes dans un tableau.

Il fonctionne très bien mais c'est tres lent et en plus je voudrais le simplifier car je dois rajouter bcp d'occurence , au moins jusqu'a la colonne AK ...

Je sais qu'il faudrait certainement utiliser d'autre boucle FOR mais chaque fois que j'essaie ca fait tout planter et ca filtre pas.

Sub Segment()

Application.ScreenUpdating = False

With ActiveSheet.UsedRange

vf11 = Range("C16").Value

vf12 = Range("D16").Value

vf13 = Range("E16").Value 'a continuer jusqu'a AK16

For I11 = 17 To .Rows.Count

N11 = Application.CountIfs(.Range("C" & I11), "*" & vf11 & "*")

N12 = Application.CountIfs(.Range("D" & I11), "*" & vf12 & "*")

N13 = Application.CountIfs(.Range("E" & I11), "*" & vf13 & "*") ' a continuer jusqu'a N44 avec AK&I11

If Not N11 > 0 Or Not N12 > 0 Or Not N13 > 0 Then .Rows(I11).Hidden = True ' a continuer jusqu'a N44

Next I11

ActiveWindow.ScrollRow = 1

End With

End Sub

Merci à celui qui prendra le temps de jeter un oeil

Nicolas

Bonjour,

J'ai créer un fichier de saisi de Facture avec une mise en forme conditionnelle qui permet de "colorier" les factures avec deux couleurs alternées pour chaque mois : janvier en bleu, février en jaune, mars en bleu ... . Le truc c'est que j'ai une Macro qui permet d'insérer une ligne en haut de ma liste de facture et une seconde Marco qui permet de les trier par mois, je fais également des "copié collé" parfois sur certaines cellules. Du coup ma mise en forme conditionnelle à l'origine en deux règles sur l'ensemble des cellules se divisent en énormément de règles divisées sur pleins de cellules.

En soit ça fonctionne, mais je me demande si cela ne va pas faire "ramer" mon fichier à force de rajouter des règles de mise en forme ?

Du coup j'ai pensé à une macro dans le code source de la page qui reprend ce principe si quelqu'un sait le faire ?

Merci d'avance,

Antho-

Bonjour

j'ai un petit souci avec ma macro recherche haut

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address = "$A$3" Or Target.Address = "$B$3" And Target.Count = 1 Then
     If [A3] <> "" And [B3] <> "" Then
        ChampFormule = "H3:H104"
        chemin = Range("A3")
        Fichier = Range("B3")
        NomTableRecherche = "$D:$AS"
        If Dir(chemin & "\" & Fichier) <> "" Then
           Range(ChampFormule).Formula = _
             "=HLOOKUP($H$2," & "'" & chemin & "\" & Fichier & "'!" & NomTableRecherche & ",LIGNE(3:3),FALSE)"
        Else
            MsgBox "fichier inconnu"
        End If
     End If
   End If
End Sub

a l'écriture ligne(3:3) est en minuscule et me produit une erreur #nom?

comment puis je faire pour qu'il reste en majuscule

merci

Recherches récentes

esterreur vbafonction erreurenlever tabulationmacro synthesejpgcompilationandpage suivante vbamodele emailouvrir modele email automatiquehttp viktorianews victoriancichlids htsrv login php redirect_to https www dvd access comouvrir modele emaillistbox multitcd sourcesrecherchev feuillesuivi candidatsenregistrerrecuperer donnees externesrecuperer lien externeajouter donnee userform