Cases à cocher

Bonjour,

Et bonne année à tous et toues

Voilà mon problème :

J'ai un tableau Excel avec une macro qui me permet d'importer dans un tableau les données provenant d'un fichier extérieur.

Cette macro ajoute des données sur les colonnes A à F.

Les données peuvent être plus ou moins importante (nombre de lignes aléatoires en fonction des journées traitées)

Je cherche à ajouter à droite de ces données des cases à cocher "oui" et "non" qui sont reliées à la case dans laquelle elles se trouvent.

"Oui" en colonne G

"Non" en colonne H

Pour se faire, j'ai trouvé une macro sur le net que j'ai bêtement intégré à la macro existante :

Option Explicit

Sub Import()
    Dim Fichier As String, fd As Object, nom$, wbks As Workbook, fin&, aa, i&, wbkc As Workbook, fin1&
    Set fd = Application.FileDialog(1)
    Set wbkc = ThisWorkbook
    fin1 = wbkc.ActiveSheet.Cells.Find("*", , xlValues, , 1, 2, 0).Row + 1
    With fd
        Fichier = ThisWorkbook.Path
        .Title = "Choisissez le fichier 'changement de prix' extrait de BackStore"
        .InitialFileName = Fichier '& "\*"
        .ButtonName = "Importer"
        .Filters.Clear
        '.Filters.Add "Fichier Excel", "*.xls"
        .AllowMultiSelect = False
        If .Show <> 0 Then
            nom = .SelectedItems(1)
            Set wbks = Workbooks.Open(nom)
            fin = wbks.ActiveSheet.Cells.Find("*", , xlValues, , 1, 2, 0).Row
            aa = wbks.ActiveSheet.Range("B27:AV" & fin)
            Application.ScreenUpdating = 0
            wbks.Close 0
            For i = 1 To UBound(aa)
                If aa(i, UBound(aa, 2)) Like "*Virtual Cashier*" Then
                    wbkc.ActiveSheet.Cells(fin1, 1) = aa(i, 1)
                    wbkc.ActiveSheet.Cells(fin1, 2) = aa(i, 5)
                    wbkc.ActiveSheet.Cells(fin1, 3) = aa(i, 10)
                    wbkc.ActiveSheet.Cells(fin1, 4) = aa(i, 15)
                    wbkc.ActiveSheet.Cells(fin1, 5) = aa(i, 33)
                    fin1 = fin1 + 1
                End If
            Next i
            wbkc.ActiveSheet.Range("A7:H" & fin1 - 1).Borders.LineStyle = 1
            wbkc.ActiveSheet.Columns("A:E").HorizontalAlignment = xlCenter

            Dim rngCel As Range
            Dim ChkBx As CheckBox
            wbkc.ActiveSheet.Range("G7:G" & fin1 - 1).Select
            For Each rngCel In Selection
  With rngCel.MergeArea.Cells
    If .Resize(1, 1).Address = rngCel.Address Then
      .NumberFormat = ";;;"
      Set ChkBx = ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
      With ChkBx
        'valeur initiale :
        .Value = xlOff 'pourrait être True ou False
        'cellule liée
        .LinkedCell = rngCel.MergeArea.Cells.Address
        'Texte de remplacement
        '.Characters.Text = "TITI"
        'texte
        .Text = "Oui" ' ou : .Caption = "Toto"
        'bordure :
        With .Border
          'Style de ligne
          '.LineStyle = xlLineStyleNone 'ou xlContinuous 'ou xlDashDot ou xlDashDotDot ou xlDot
          'couleur
          '.ColorIndex = 3  '3 = rouge
          'épaisseur du trait
          '.Weight = 4
        End With
        'accessibles aussi les propriétés .Locked, .Name, .Enabled etc...
      End With
    End If
  End With
Next rngCel

            wbkc.ActiveSheet.Range("H7:H" & fin1 - 1).Select
            For Each rngCel In Selection
  With rngCel.MergeArea.Cells
    If .Resize(1, 1).Address = rngCel.Address Then
      .NumberFormat = ";;;"
      Set ChkBx = ActiveSheet.CheckBoxes.Add(.Left, .Top, .Width, .Height)
      With ChkBx
        'valeur initiale :
        .Value = xlOff 'pourrait être True ou False
        'cellule liée
        .LinkedCell = rngCel.MergeArea.Cells.Address
        'Texte de remplacement
        '.Characters.Text = "TITI"
        'texte
        .Text = "Non" ' ou : .Caption = "Toto"
        'bordure :
        With .Border
          'Style de ligne
          '.LineStyle = xlLineStyleNone 'ou xlContinuous 'ou xlDashDot ou xlDashDotDot ou xlDot
          'couleur
          '.ColorIndex = 3  '3 = rouge
          'épaisseur du trait
          '.Weight = 4
        End With
        'accessibles aussi les propriétés .Locked, .Name, .Enabled etc...
      End With
    End If
  End With
Next rngCel

        Else
            MsgBox "Vous n'avez sélectionné aucun fichier dans votre dossier", , "Manque de Sélection": GoTo 1
        End If
    End With
1
End Sub

Le résultat est horrible à lire et en plus deux problèmes se posent :

1. j'ai un débogage parce que la macro a l'air reliée à un autre doc (mais je ne vois pas où modifier ça)

2. les cases à cocher se cumulent sur les lignes déjà occupées... En gros si hier j'ai eu 2 lignes, j'ai des cases à cocher sur G7 et G8 et sur H7 et H8. Ce matin, ca me remettra, par dessus, des cases à cocher sur ces cellules au lieu de continuer en dessous...

J'espère avoir été clair :s

Merci d'avance pour votre aide

Excellente journée,

Loïc

Bonjour

Pour trouver une solution tes 2 fichiers sont indispensables

Re

Veuillez trouver ci joint les fameux fichiers. (A savoir que j'ai mis le fichier principal avec la macro qui fonctionne pour vous permettre de visualiser le résultat (sans les cases à cocher))

J'ai mis :

  • "exemple_extraction.xls" qui correspond au fichier contenant les données qui s'ajoutent au fichier principal
  • "Exemple1.xlsm" qui est le fichier principal dans lequel les données s'insèrent et contenant la macro

Pour info, dans le fichier "Exemple1.xlsm", la colonne F "Numéro collaborateur" est saisie manuellement. En colonne G et H doivent apparaitre les cases à cocher.

Enfin, j'ai découvert un autre problème, le format date est inversé alors que la cellule a l'air bien paramétrée...

Excellent journée,

Merci d'avance,

Loïc

37exemple1.xlsm (19.70 Ko)

Bonjour

A tester

Re

Merci infiniment pour la rapidité !

J'ai une dernière chose, il y a toujours ce bug qui se produit sur le format de la date. Le jour et le mois sont inversés alors que c'est ok sur le fichier de base et dans le format de la cellule d'accueil.

Merci encore,

Bonne soirée,

Loïc

Bonjour

Modifie la ligne correspondante

wbkc.ActiveSheet.Cells(fin1, 1) = CDate(aa(i, 1))
Rechercher des sujets similaires à "cases cocher"