{Résolu} Valeur revoyee par SpecialCells(xlCellTypeVisible) ?

[g.milano]

bonjour,

j'ai un probleme avec la fonction SpecialCells(xlCellTypeVisible).

Suite a un filtre elabore, je copie le resultat du filtre dans une autre feuille.

Mais lorsqu'il n'y a pas de resultats pour les criteres demandes, la macro plante (erreur 1004).

Apres d'autres recherches, j'en suis arrive a la conclusion que c'est le specialCells(xlCellTypeVisible) qui genere l'erreur. Meme en tentant des tests genre if range("").SpecialCells(xlCellTypeVisible) is nothing, je n'ai pas de resultats (en fait, le resultat du if/then est le meme qu'il y ait ou non des cellules visibles).

Donc est-ce que quelqu'un aurait la bonte de me dire comment tester ce cas, ou me dire si c'est impossible (et je devrais trouver une autre solution, mais je ne vois pas laquelle T_T)

    'Kopikol imp
    retsu = WorksheetFunction.CountA(Columns("B"))
    crit = WorksheetFunction.CountA(Sheets("ﾌｨﾙﾀｰ").Rows("1"))
    For m = 1 To crit
        insatsuh = WorksheetFunction.CountA(Sheets("印刷").Columns("C")) + 1
        insatsum = WorksheetFunction.CountA(Sheets("印刷").Columns("I")) + 1
        If insatsuh > insatsum Then
            hashira = "I"
            insatsu = insatsum
        Else
            hashira = "C"
            insatsu = insatsuh
        End If
        ran = Chr(m + 64)
        critnb = WorksheetFunction.CountA(Sheets("ﾌｨﾙﾀｰ").Columns(ran))
        Range("A:B").AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=Sheets("ﾌｨﾙﾀｰ").Range(ran & "1:" & ran & critnb), Unique:=False
        Range("A1:B" & retsu).SpecialCells(xlCellTypeVisible).Copy
        Sheets("印刷").Range(hashira & insatsu).PasteSpecial Paste:=xlPasteValues
        Range("A1:B" & retsu).SpecialCells(xlCellTypeVisible).ClearContents
    ActiveSheet.ShowAllData
    Next m
    With Sheets("印刷")
        .Activate
        .PrintPreview
    End With

merci pour votre aide m(_ _)m

 

[Pierrot93]

Re : Valeur revoyee par SpecialCells(xlCellTypeVisible) ?

Bonjour,

regarde ceci, à adapter à ton fichier, peut être te permettra d'avancer :

Dim p As Range
Set p = Range("_FilterDatabase")
If WorksheetFunction.Subtotal(3, p.Offset(1).Resize(p.Rows.Count - 1, 1)) > 0 Then
    p.Offset(1).Resize(p.Rows.Count - 1).Copy Sheets("feuil2").Range("A1")
End If

bonne journée
@+

 

[g.milano]

Re: Re : Valeur revoyee par SpecialCells(xlCellTypeVisible) ?

excellent, l'astuce du sous-total !!!

merci infiniment, ca marche nickel maintenant ! Je mets la version corrigee, des fois que ca serve a quelqu'un.

    'Kopikol imp
    retsu = WorksheetFunction.CountA(Columns("B"))
    crit = WorksheetFunction.CountA(Sheets("ﾌｨﾙﾀｰ").Rows("1"))
    For m = 1 To crit
        insatsuh = WorksheetFunction.CountA(Sheets("印刷").Columns("C")) + 1
        insatsum = WorksheetFunction.CountA(Sheets("印刷").Columns("I")) + 1
        If insatsuh > insatsum Then
            hashira = "I"
            insatsu = insatsum
        Else
            hashira = "C"
            insatsu = insatsuh
        End If
        ran = Chr(m + 64)
        critnb = WorksheetFunction.CountA(Sheets("ﾌｨﾙﾀｰ").Columns(ran))
        Range("A:B").AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=Sheets("ﾌｨﾙﾀｰ").Range(ran & "1:" & ran & critnb), Unique:=False
        Set kekka = Range("A2:A" & retsu)
        If WorksheetFunction.Subtotal(103, kekka) > 0 Then
            Range("A2:B" & retsu).SpecialCells(xlCellTypeVisible).Copy
            Sheets("印刷").Range(hashira & insatsu).PasteSpecial Paste:=xlPasteValues
            Range("A2:B" & retsu).SpecialCells(xlCellTypeVisible).ClearContents
        End If
        ActiveSheet.ShowAllData
    Next m
    With Sheets("印刷")
        .Activate
        .PrintPreview
    End With