Problème de dépassement de capacité WorksheetFunction.CountARésolu

Question

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 !

ucfoutu · Accepted Answer

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

cs_Jack · Answer

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)

gondrule1 · Answer

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 !

Renfield · Answer

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

gondrule1 · Answer

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 !

gondrule1 · Answer

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 !

Renfield · Answer

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

ucfoutu · Answer

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

gondrule1 · Answer

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

gondrule1 · Answer

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 !

ucfoutu · Answer

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

Renfield · Answer

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

gondrule1 · Answer

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

ucfoutu · Answer

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

Problème de dépassement de capacité WorksheetFunction.CountA

14 réponses

Votre réponse