Problème de dépassement de capacité WorksheetFunction.CountA [Résolu]

gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 11 déc. 2011 à 12:11 - Dernière réponse : ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention
- 13 déc. 2011 à 11:04
Bonjour,

J'ai "écrit" (disons pour beaucoup) copié cette macro pour qu'une page soit créée et renommée pour chaque range commençant à A2 sur la feuille1. Elle fonctionne à ceci près que pour automatiser la création et ne pas être obligé de relancer la macro à chaque fois, j'ai ajouté un Do Until qui m'oblige à ajouter un texte dans la 1ère ligne vide de la fin de la colonne A de la feuille1 pour que la macro se termine proprement. Si je n'écris pas ce texte, j'ai un message de "dépassement de capacité" et la dernière feuille contenant les données n'est pas créée:
Sub CopyData()

    Dim LRow As Integer
    Dim LColARange As String
    Dim LContinue As Boolean
    Dim x As String
    Dim sh As Worksheet
Do Until WorksheetFunction.CountA(Range("A2:A65536")) = 1
    'Select Sheet1
    Sheets("Feuil1").Select
    Range("A2").Select
x = Selection.Value

    'Initialize variables
    LContinue = True
    LRow = 1

    'Loop through all column A values until a cell (other than blank) value does not
    ' match cell A2's value
    While LContinue = True

        LRow = LRow + 1
        LColARange = "A" & CStr(LRow)
        
       'Found a blank cell, do continue
        If Len(Range(LColARange).Value) = 0 Then
            LContinue = True
          

        'Found first occurrence that did not match cell A2's value, do not continue
     ElseIf Range("A2").Value <> Range(LColARange).Value Then
            LContinue = False
        End If

    Wend

    'Copy data from columns A - G
    Range("A2:G" & CStr(LRow - 1)).Select
    Selection.Copy
ThisWorkbook.Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = x
    Worksheets(x).Paste Destination:=Worksheets(x).Range("A3")

  
Sheets("Feuil1").Select
Selection.EntireRow.Delete

Loop
Application.CutCopyMode = False
End Sub


Auriez-vous une solution à me proposer ?
D'avance, merci

Bonne fin de week-end !
Afficher la suite 

Votre réponse

14 réponses

Meilleure réponse
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 11 déc. 2011 à 20:03
3
Merci
Bonjour,
Bon ...
Je vais personnellement attendre que tu ré-expliques tout en termes simples, clairs, précis et techniques, car entre ton premier et ton second message, on en voit de toutes les couleurs, sans cerner le problème !
prends ton temps et n'enrobe pas de tout un pot de confiture ce qui devrait pouvoir s'exprimer clairement et en quelques mots seulement.


____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient

Merci ucfoutu 3

Avec quelques mots c'est encore mieux Ajouter un commentaire

Codes Sources a aidé 97 internautes ce mois-ci

Commenter la réponse de ucfoutu
Meilleure réponse
Renfield 17308 Messages postés mercredi 2 janvier 2002Date d'inscription 22 août 2018 Dernière intervention - 12 déc. 2011 à 15:05
3
Merci
y'a qu'a modifier un brin le code de sortie de la boucle :


Sub CopyData()
Dim reference As String
Dim sheetSrc As Worksheet
Dim sheetDst As Worksheet
Dim oRange As Range
Dim maxRow  As Long
    Set sheetSrc = Sheets("Feuil1")
    Do While WorksheetFunction.CountA(sheetSrc.Range("A2:A65536")) > 0
        maxRow = sheetSrc.Range("A:A").SpecialCells(xlCellTypeLastCell).Row
        reference = sheetSrc.Range("A2").Text
        Set oRange = sheetSrc.Range("A3")
        '# Loop through all col A values until a non-blank cell value that does not match A2's value is found
        Do
            If LenB(oRange.Text) > 0 And oRange.Text <> reference Then
                Exit Do
            End If
            Set oRange = oRange.Offset(1)
        Loop While oRange.Row < maxRow
    
        'Copy data from columns A - G
        Set oRange = sheetSrc.Range("A2", sheetSrc.Cells(oRange.Row - 1, 7))
        Set sheetDst = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        sheetDst.Name = reference
        oRange.Copy sheetDst.Range("A3")
        oRange.EntireRow.Delete
    Loop
End Sub


Renfield - Admin CodeS-SourceS - MVP Visual Basic & Spécialiste des RegExp

Merci Renfield 3

Avec quelques mots c'est encore mieux Ajouter un commentaire

Codes Sources a aidé 97 internautes ce mois-ci

Commenter la réponse de Renfield
Meilleure réponse
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 12 déc. 2011 à 17:21
3
Merci
Ouais
Bien dommage que tu ne dises pas exactement ce dont il s'agit (et je ne veux pas ouvrir ton fichier).
Je croisd avoir deviné que sur une feuille, tu as une ligne de titres, puis des "blocs/groupes" d'articles, chaque groupe ne se distinguant que par un nom donné en colonne A, en sa seeule 1ère ligne.
C'est cela ?

Si oui et en admettant que la feuille où se trouvent tous ces groupes soit la feuille nommée "Feuil1" ===>>

Dim dercel As Range, deb As Range, dest As Worksheet
  Do
    With Sheets("Feuil1")
      Set dercel = .Cells.SpecialCells(xlCellTypeLastCell)
      Set deb = .Range("A" & dercel.Row).End(xlUp)
      If deb.Row = 1 Then Exit Do
      Set dest = Worksheets.Add(After:=Worksheets(Worksheets.Count))
      dest.Name = .Range(deb.Address)
      .Range(deb.Address, dercel.Address).Copy Destination:=dest.Range("A1")
      .Range(deb.Address, dercel.Address).EntireRow.Delete
    End With
  Loop

devrait "faire l'affaire"

____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient

Merci ucfoutu 3

Avec quelques mots c'est encore mieux Ajouter un commentaire

Codes Sources a aidé 97 internautes ce mois-ci

Commenter la réponse de ucfoutu
cs_Jack 14010 Messages postés samedi 29 décembre 2001Date d'inscription 28 août 2015 Dernière intervention - 11 déc. 2011 à 12:56
0
Merci
Salut

Sur quelle ligne s'arrête t-il avec cette erreur ?
C'est une info importante.

Un Integer n'accepte de valeur que de -32768 à +32765.
Tu tentes de créer 32768 lignes, soit un de trop pour LRow
Essaye de le transformer en Long.

Pour simplifier ton code et sa compréhension, regarde la méthode .Offset de l'objet Range : Il permet de désigner une cellule relativement à l'emplacement du Range. Cela t'éviterais de jongler avec ta construction de LColARange.
Exemple : Range("A1").Offset(10,2) désigne la ligne 11 (1+10) et la colonne C (A+2)

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)
Commenter la réponse de cs_Jack
gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 11 déc. 2011 à 17:02
0
Merci
Salut,

En fait, je me suis très mal exprimé.
Avant, dans mon code j'avais mis
Do While WorksheetFunction.CountA(Range("A2:A65536")) <> 0
et c'est là que j'avais le message d'erreur.
Je pense qu'avec le code de la macro (avec Do While), lorsqu'on arrivait au dernier range à créer (à partir de A2), il ne trouve plus rien d'autre que des cellules vides dans la colonne A, et comme il est censé les conserver pour créer le range, c'est ce qui créait ce dépassement de capacité et l'empêchait de créer la dernière feuille. Avec Do Until (comme c'est le cas maintenant dans la macro et avec =1 ), il ne crée pas d'erreur, mais cela m'oblige à créer/renommer/la feuille du dernier range et y coller les informations du range subsistant dans la Feuil1, à moins d'ajouter un texte "blabla" dans la ligne suivant la dernière ligne du dernier range.
Malheureusement, je ne peux pas utiliser la méthode Offset puisqu'il s'agit de ranges variables (le nombre de lignes varie)
Peut-être qu'il faudrait que je fasse soit :
- un For each au lieu d'un Do Until et que je définisse par un Case le dernier cas de figure (dernier range), mais il faudrait (je pense ...)que j'utilise une variable range où je stockerais la valeur du range
ou alors
- un If qui dirait que si toutes les cellules restantes de la colonne A après la cellule A2 sont vides, de "scanner" les autres colonnes pour créer le range en fonction de la ligne de la dernière cellule utilisée (qui peut etre sur n'importe quelles colonnes entre B et G) et alors créer une nouvelle feuille (en recopiant le code
 Range("A2:G" & CStr(LRow - 1)).Select
    Selection.Copy
ThisWorkbook.Sheets.Add After:=Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = x
    Worksheets(x).Paste Destination:=Worksheets(x).Range("A3")
  Sheets("Feuil1").Select
Selection.EntireRow.Delete

après Application.CutCopyMode = False

Bon je vais encore y réfléchir...
En tous cas, merci pour ton soutien !
Bonne fin de week-end !
Commenter la réponse de gondrule1
Renfield 17308 Messages postés mercredi 2 janvier 2002Date d'inscription 22 août 2018 Dernière intervention - 12 déc. 2011 à 08:18
0
Merci
y'a encore une fois pas besoin de jouer avec la selection...

c'est lent et moche :

Sheets("Feuil1").Select
Range("A2").Select
x = Selection.Value

devient:

x = Sheets("Feuil1").Range("A2").Value


LColARange = "A" & CStr(LRow)
'Found a blank cell, do continue
If Len(Range(LColARange).Value) = 0 Then
LContinue = True


'Found first occurrence that did not match cell A2's value, do not continue
ElseIf Range("A2").Value <> Range(LColARange).Value Then
LContinue = False
End If

NON !

pas d'accord avec la concaténation pour obtenir LColARange...

faire :

LColARange = Cells(LRow, 1)


et dans
ElseIf Range("A2").Value <> Range(LColARange).Value Then
LContinue = False
End If
pourquoi passer par Range("A2").Value
et non par 'x', enregistrée avant ta boucle ?



En gros, je dirai :

Sub CopyData()
Dim index As String
Dim sheetSrc As Worksheet
Dim sheetDst As Worksheet
Dim oRange As Range
    Set sheetSrc = Sheets("Feuil1")
    Do While WorksheetFunction.CountA(sheetSrc.Range("A2:A65536")) > 0
        index = sheetSrc.Range("A2").Text
        Set oRange = sheetSrc.Range("A3")
        '# Loop through all col A values until a non-blank cell value that does not match A2's value is found
        Do
            If oRange.Text <> index Then
                Exit Do
            End If
            Set oRange = oRange.Offset(1)
        Loop
    
        'Copy data from columns A - G
        Set oRange = sheetSrc.Range("A2", sheetSrc.Cells(oRange.Row - 1, 7))
        Set sheetDst = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        sheetDst.Name = index
        oRange.Copy sheetDst.Range("A3")
        oRange.EntireRow.Delete
    Loop
End Sub


Renfield - Admin CodeS-SourceS - MVP Visual Basic & Spécialiste des RegExp
Commenter la réponse de Renfield
gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 12 déc. 2011 à 08:48
0
Merci
Salut à tous,

Merci pour vos réponses, Renfield, merci pour ton code (c'est sûr c'est plus compact) je le testerai ce soir !

Bonne journée !
Commenter la réponse de gondrule1
gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 12 déc. 2011 à 14:14
0
Merci
Re-salut,

Finalement j'ai posté sur le site Cjoint.com un échantillon de mon tableau, à cette adresse http://cjoint.com/?ALmnQuvKV55, pour que vous puissiez vous faire une meilleure idée du tableau.
J'ai testé le code fourni, mais il ne copie que la 1ère ligne du range de la référence1 sur une nouvelle feuille qu'il renomme correcterment et ensuite il crée une nouvelle feuille qu'il ne renomme pas et ensuite j'ai une erreur "400" ou une erreur "1004"...Method Name of object worksheet failed
Bonne fin de journée !
Commenter la réponse de gondrule1
gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 12 déc. 2011 à 19:34
0
Merci
Resalut,

Merci à tous les 2, pour votre aide !
Effectivement, ta modification du code a porté ses fruits cela marche du tonnerre de Dieu !.
Je n'ai pas encore testé ton code Ucfoutu mais je le ferai.
J'ai reposté un lien qui contient une image de mon tableau cette fois, donc tu peux l'ouvrir sans crainte http://cjoint.com/?ALmtDlFhL47


Bonne soirée
Commenter la réponse de gondrule1
gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 12 déc. 2011 à 20:06
0
Merci
Resalut,

Je viens de tester ta macro Ucfoutu et elle fonctionne très bien !
J'imagine qu'elle travaille à partir de la fin du tableau parce qu'elle inverse les feuilles ( Référence3,Référence2, Référence1) mais cela n'a aucune incidence sur ce que je veux faire !

Bravo à toi !
Commenter la réponse de gondrule1
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 12 déc. 2011 à 22:29
0
Merci
ben,
si tu les veux dans l'autre sens, y compris en tête, si tu veux :
suffit de remplacer cette ligne
Set dest = Worksheets.Add(After:=Worksheets(Worksheets.Count))

par celle-ci :
Set dest = Worksheets.Add(before:=Worksheets(1))

C'est tout
____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient
Commenter la réponse de ucfoutu
Renfield 17308 Messages postés mercredi 2 janvier 2002Date d'inscription 22 août 2018 Dernière intervention - 13 déc. 2011 à 07:37
0
Merci
Pas mal ucfoutu, cette histoire de laisser Excel trouver le début de la Range.

pas mal... (je note)

Renfield - Admin CodeS-SourceS - MVP Visual Basic & Spécialiste des RegExp
Commenter la réponse de Renfield
gondrule1 33 Messages postés lundi 29 septembre 2008Date d'inscription 29 février 2012 Dernière intervention - 13 déc. 2011 à 08:03
0
Merci
Salut !
encore merci à tous les 2...
Prochaine étape : créer des fichiers xml à partir d'excel avec les pages obtenues... par macro ...
Mais je ferai ça pendant les vacances qui approchent...

Bonnes fêtes de fin d'année
Commenter la réponse de gondrule1
ucfoutu 18039 Messages postés lundi 7 décembre 2009Date d'inscriptionContributeurStatut 11 avril 2018 Dernière intervention - 13 déc. 2011 à 11:04
0
Merci
Bonjour, Renfield,
Heureux que cela t'ait intéressé
A vrai dire, le nombre de chemin menant à Rome est infini.
Regarde, par exemple, ce qu'on aurait pu également faire :
With Sheets("Feuil1")
    Dim plage As Range, dercel As Range, dest As Worksheet
    Set dercel = .Cells.SpecialCells(xlCellTypeLastCell)
    Set plage = .Range("A2:A" & dercel.Column)
    Set plage = plage.SpecialCells(xlCellTypeConstants)
    For i = plage.Areas.Count To 1 Step -1
      Set dest = Worksheets.Add(before:=Worksheets(1))
      dest.Name = plage.Areas(i)
      .Range(plage.Areas(i), dercel).Copy Destination:=dest.Range("A1")
      Set dercel = .Cells(plage.Areas(i).Row - 1, dercel.Column)
    Next
    .Cells.ClearContents
  End With

également amusant et tout aussi efficace.
PS : ce dernier code n'est là que pour Renfield (je préfère l'autre, personnellement) et pour qu'en en rie ensemble.


____________________
Réponse exacte ? => "REPONSE ACCEPTEE" pour faciliter les recherches d'autres forumeurs.
Pas d'aide en ligne installée ? ==> ne comptez pas sur moi pour simplement vous dire ce qu'elle contient
Commenter la réponse de ucfoutu

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.