XL 2016 Boucler sur les feuilles d'un classeur

KTM à dit:

Bonjour chers tous
j'ai une macro avec boucle qui fait ceci :
j'insère en [Date!B6] une date et la feuille avec la même date en [B1] voit sa plage [A3:A19] remplie avec de "ok"
La macro fonctionne mais je voudrais pouvoir vérifier avant pour chacune des feuilles si les dates en [B1] sont uniques et comprennent la date insérée en [B6] de la feuille Date.

VB:

Sub impr()
Dim sh1, sh As Worksheet
Dim sh2 As Worksheet
Dim wb As Workbook
        Set wb = ThisWorkbook
        Set sh1 = ThisWorkbook.Worksheets("Date")
        For Each sh In wb.Worksheets
           Set sh2 = sh
           Application.ScreenUpdating = False
               If sh2.Range("B1") = sh1.Range("B6") Then
                   With sh2
                     .Range("A3:A19") = "ok"
                   End With
               Exit For
              End If
         Next sh
End Sub

Cliquez pour agrandir...

cathodique à dit:

Bonsoir,

J'avoue que je n'ai pas bien compris ta demande.
Tu as parlé de date en double, c'est un peu confus.
j'ai mis la même date sur un autre feuille, mais comme tu as mis un exit for,
il n'y en a qu'une seule qui est traitée.
Je n'ai pas compris donc pas possible de t'aider.

Bonne continuation.

Cliquez pour agrandir...

Cousinhub à dit:

Bonsoir,
Si j'ai bien compris...

VB:

Sub impr2()
Dim LaDate As Date
Dim Sh As Worksheet
LaDate = Worksheets("Date").Range("B6")
For Each Sh In Sheets
    If Sh.Range("B1") = LaDate Then Sh.Range("A3:A19") = "ok"
Next Sh
End Sub

Cliquez pour agrandir...

KTM à dit:

Merci mais je me suis pas encore fait comprendre.
La macro n'a aucun probleme a fonctionner.
Ma preoccupation cest comment verifier que toutes les feuilles apart la feuille Date ont des dates en B1 differentes et que la date indiquee comme reference existe parmis les dates sur les feuilles.

Cliquez pour agrandir...

Sub impr()
   Dim sh1, sh As Worksheet
   Dim sh2 As Worksheet
   Dim wb As Workbook
   Set wb = ThisWorkbook
   Set sh1 = ThisWorkbook.Worksheets("Date")
   For Each sh In wb.Worksheets
      If sh.Name <> sh1.Name Then 'condition sur nom de la feuille
         Set sh2 = sh
         Application.ScreenUpdating = False
         If sh2.Range("B1") = sh1.Range("B6") Then
            With sh2
               .Range("A3:A19") = "ok"
            End With
            Exit For
         End If
      End If
   Next sh
End Sub

KTM à dit:

je voudrais pouvoir vérifier avant pour chacune des feuilles si les dates en [B1] sont uniques et comprennent la date insérée en [B6] de la feuille Date.

Cliquez pour agrandir...

Sub Test()
' Remplissage du TS avec les dates des feuilles
Dim wb As Workbook
Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet
Dim LR As Long
Dim Msg1 As String, Msg2 As String

    Application.ScreenUpdating = False

    Set wb = ThisWorkbook
    Set sh1 = wb.Worksheets("Date")
    Set sh2 = wb.Worksheets("Tempo")

    With Range("t_Dates").ListObject
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    End With

    For Each sh In wb.Worksheets
        If sh.Name <> "Date" And sh.Name <> "Tempo" Then
            Range("t_Dates").ListObject.ListRows.Add
            LR = Range("t_Dates").ListObject.ListRows.Count
            Range("t_Dates").Cells(LR, 1) = sh.Name
            Range("t_Dates").Cells(LR, 2) = sh.Range("B1").Value2
        End If
    Next sh

    If sh2.Range("H2") = 0 Then
        Msg1 = "Pas de dates en double"
    Else
        Msg1 = "/!\ Il y a au moins une date en double !"
    End If

    If sh2.Range("K2") = 0 Then
        Msg2 = "La date référence non trouvée"
    Else
        Msg2 = "/!\ Date de référence trouvée au moins une fois !"
    End If

    sh2.Activate
    Application.ScreenUpdating = True
    MsgBox Msg1 & vbCrLf & vbCrLf & Msg2

End Sub

TooFatBoy à dit:

Hello,


Une version avec une feuille supplémentaire te permettant une vérification visuelle.

VB:

Sub Test()
' Remplissage du TS avec les dates des feuilles
Dim wb As Workbook
Dim sh As Worksheet, sh1 As Worksheet, sh2 As Worksheet
Dim LR As Long
Dim Msg1 As String, Msg2 As String

    Application.ScreenUpdating = False

    Set wb = ThisWorkbook
    Set sh1 = wb.Worksheets("Date")
    Set sh2 = wb.Worksheets("Tempo")

    With Range("t_Dates").ListObject
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    End With

    For Each sh In wb.Worksheets
        If sh.Name <> "Date" And sh.Name <> "Tempo" Then
            Range("t_Dates").ListObject.ListRows.Add
            LR = Range("t_Dates").ListObject.ListRows.Count
            Range("t_Dates").Cells(LR, 1) = sh.Name
            Range("t_Dates").Cells(LR, 2) = sh.Range("B1").Value2
        End If
    Next sh

    If sh2.Range("H2") = 0 Then
        Msg1 = "Pas de dates en double"
    Else
        Msg1 = "/!\ Il y a au moins une date en double !"
    End If

    If sh2.Range("K2") = 0 Then
        Msg2 = "La date référence non trouvée"
    Else
        Msg2 = "/!\ Date de référence trouvée au moins une fois !"
    End If

    sh2.Activate
    Application.ScreenUpdating = True
    MsgBox Msg1 & vbCrLf & vbCrLf & Msg2

End Sub

Cliquez pour agrandir...