Longueur ligne de code

tactic6

XLDnaute Impliqué
Bonjour le forum
j'ai compilé un bout de code qui doit copier des cellules d'un tableau pour les transcrire sur une ligne d'une autre feuille mais apparement la ligne est trop longue et je ne sais pas comment l'ecrire
Code:
For Each cellule In Worksheets("Facture").Range("J6,h5,C12,G8,H9,G10,h12,B15,C15,H15,I15,K15,B16,C16,H16,I16,K16,B17,C17,H17,I17,K17,B18,C18,H18,I18,K18,B19,C19,H19,I19,K19,B20,C20,H20,I20,K20,B21,C21,H21,I21,K21,B22,C22,H22,I22,K22,B23,C23,H23,I23,K23,B24,C24,H24,I24,K24,B25,C25,H25,I25,K25,B26,C26,H26,I26,K26,B27,C27,H27,I27,K27,B28,C28,H28,I28,K28,B29,C29,H29,I29,K29,B30,C30,H30,I30,K30,B31,C31,H31,I31,K31,B32,C32,H32,I32,K32,B33,C33,H33,I33,K33,B34,C34,H34,I34,K34,B35,C35,H35,I35,K35,B36,C36,H36,I36,K36,B37,C37,H37,I37,K37,B38,C38,H38,I38,K38,B39,C39,H39,I39,K39,B40,C40,H40,I40,K40,B41,C41,H41,I41,K41,B42,C42,H42,I42,K42,B43,C43,H43,I43,K43,B44,C44,H44,I44,K44,B45,C45,H45,I45,K45,B46,C46,H46,I46,K46,B47,C47,H47,I47,K47,B48,C48,H48,I48,K48,B49,C49,H49,I49,K49,B50,C50,H50,I50,K50,B51,C51,H51,I51,K51,B52,C52,H52,I52,K52,J54,B55,C55,D55,B56,C56,D56,B57,C57,D57,J55,J56,J57,J58,j59")

le code entier

Code:
Sub Transfert()
Dim ligne As Integer
Dim colonne As Byte
Dim cellule As Range

Sheets("facture").Select

If Range("C12").Value = "" Then
MsgBox "Il n' y a pas de nom, la facture ne peut pas être enregistrée"
Exit Sub
End If
If Range("J6").Value = "" Then
MsgBox "Il n' y a pas de numéro, la facture ne peut pas être enregistrée"
Exit Sub
End If
If Range("H5").Value = "Date" Then
MsgBox "Il n' y a pas de Date, la facture ne peut pas être enregistrée"
Exit Sub
End If
ligne = Worksheets("Feuil1").Range("A65536").End(xlUp).Row + 1

For Each cellule In Worksheets("Facture").Range("J6,h5,C12,G8,H9,G10,h12,B15,C15,H15,I15,K15,B16,C16,H16,I16,K16,B17,C17,H17,I17,K17,B18,C18,H18,I18,K18,B19,C19,H19,I19,K19,B20,C20,H20,I20,K20,B21,C21,H21,I21,K21,B22,C22,H22,I22,K22,B23,C23,H23,I23,K23,B24,C24,H24,I24,K24,B25,C25,H25,I25,K25,B26,C26,H26,I26,K26,B27,C27,H27,I27,K27,B28,C28,H28,I28,K28,B29,C29,H29,I29,K29,B30,C30,H30,I30,K30,B31,C31,H31,I31,K31,B32,C32,H32,I32,K32,B33,C33,H33,I33,K33,B34,C34,H34,I34,K34,B35,C35,H35,I35,K35,B36,C36,H36,I36,K36,B37,C37,H37,I37,K37,B38,C38,H38,I38,K38,B39,C39,H39,I39,K39,B40,C40,H40,I40,K40,B41,C41,H41,I41,K41,B42,C42,H42,I42,K42,B43,C43,H43,I43,K43,B44,C44,H44,I44,K44,B45,C45,H45,I45,K45,B46,C46,H46,I46,K46,B47,C47,H47,I47,K47,B48,C48,H48,I48,K48,B49,C49,H49,I49,K49,B50,C50,H50,I50,K50,B51,C51,H51,I51,K51,B52,C52,H52,I52,K52,J54,B55,C55,D55,B56,C56,D56,B57,C57,D57,J55,J56,J57,J58,j59")
colonne = colonne + 1
Worksheets("Feuil1").Cells(ligne, colonne) = cellule
Next cellule
Dim Derli As Long
Derli = Sheets("Feuil1").Columns("I").Find("*", , , , , xlPrevious).Row + 1
Worksheets("Feuil1").Cells(Derli, "I").Value = Now()
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub

Merci pour votre aide
et Bon WE à tous
 
C

Compte Supprimé 979

Guest
Re : Longueur ligne de code

Salut Tactic6, Catrice ;)

Sans ton fichier, pas facile, mais tu peux essayer
Code:
With Worksheets("Facture")
  For Each cellule In .Range("J6,H5,C12,G8,H9,G10,h12")
    colonne = colonne + 1
    Worksheets("Feuil1").Cells(ligne, colonne) = cellule
  Next cellule
  Dim Lig As Long
  For Lig = 15 To 52
    For Each cellule In .Range("B" & Lig & ",C" & Lig & ",H" & Lig & ",I" & Lig & ",K" & Lig)
      colonne = colonne + 1
      Worksheets("Feuil1").Cells(ligne, colonne) = cellule
    Next cellule
  Next Lig
  For Each cellule In .Range("J54,B55,C55,D55,B56,C56,D56,B57,C57,D57,J55,J56,J57,J58,j59")
      colonne = colonne + 1
      Worksheets("Feuil1").Cells(ligne, colonne) = cellule
  Next cellule
End With
Qui devrait remplacer ton For Each ... Next actuel

A+
 

kiki29

XLDnaute Barbatruc
Re : Longueur ligne de code

Salut, vite fait , donc il y a peut-être mieux
Code:
Option Explicit

Sub Transfert()
Dim ligne As Long
Dim colonne As Long
Dim cellule As Range
Dim Derli As Long
Dim i As Long, sStr As String, Ar() As String
    Sheets("facture").Select

    sStr = "J6,h5,C12,G8,H9,G10,h12,B15,C15,H15,I15,K15," & _
           "B16,C16,H16,I16,K16," & _
           "B17,C17,H17,I17,K17,B18,C18,H18,I18,K18," & _
           "B19,C19,H19,I19,K19,B20,C20,H20,I20,K20,B21,C21,H21,I21,K21," & _
           "B22,C22,H22,I22,K22,B23,C23,H23,I23,K23,B24,C24,H24,I24,K24," & _
           "B25,C25,H25,I25,K25,B26,C26,H26,I26,K26,B27,C27,H27,I27,K27," & _
           "B28,C28,H28,I28,K28,B29,C29,H29,I29,K29,B30,C30,H30,I30,K30," & _
           "B31,C31,H31,I31,K31,B32,C32,H32,I32,K32,B33,C33,H33,I33,K33," & _
           "B34,C34,H34,I34,K34,B35,C35,H35,I35,K35,B36,C36,H36,I36,K36," & _
           "B37,C37,H37,I37,K37,B38,C38,H38,I38,K38,B39,C39,H39,I39,K39," & _
           "B40,C40,H40,I40,K40,B41,C41,H41,I41,K41,B42,C42,H42,I42,K42," & _
           "B43,C43,H43,I43,K43,B44,C44,H44,I44,K44,B45,C45,H45,I45,K45," & _
           "B46,C46,H46,I46,K46,B47,C47,H47,I47,K47,B48,C48,H48,I48,K48," & _
           "B49,C49,H49,I49,K49,B50,C50,H50,I50,K50,B51,C51,H51,I51,K51," & _
           "B52,C52,H52,I52,K52,J54,B55,C55,D55," & _
           "B56,C56,D56,B57,C57,D57,J55,J56,J57,J58,j59"
    
    Ar = Split(sStr, ",")
    
    If Range("C12").Value = "" Then
        MsgBox "Il n' y a pas de nom, la facture ne peut pas être enregistrée"
        Exit Sub
    End If
    If Range("J6").Value = "" Then
        MsgBox "Il n' y a pas de numéro, la facture ne peut pas être enregistrée"
        Exit Sub
    End If
    If Range("H5").Value = "Date" Then
        MsgBox "Il n' y a pas de Date, la facture ne peut pas être enregistrée"
        Exit Sub
    End If
    ligne = Worksheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row + 1

    For i = LBound(Ar) To UBound(Ar)
        colonne = colonne + 1
        Worksheets("Feuil1").Cells(ligne, colonne) = Worksheets("Facture").Range(Ar(i))
    Next i
    
    Derli = Sheets("Feuil1").Columns("I").Find("*", , , , , xlPrevious).Row + 1
    Worksheets("Feuil1").Cells(Derli, "I").Value = Now()
    ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub
 
Dernière édition:

tactic6

XLDnaute Impliqué
Re : Longueur ligne de code

Merci kiki29
j'avais oublié une colonne
je l'ai rajoutée à ton code mais j'ai une erreur et toutes les données ne sont pas recopiées
je ne comprend vraiment pas
peux tu encore m'aider?
merci
PS je modifie le fichier joint
 

Pièces jointes

  • tactic6V2.zip
    25.9 KB · Affichages: 30
Dernière édition:

kiki29

XLDnaute Barbatruc
Re : Longueur ligne de code

Salut, toutes les données sont copiées, il y a surement d'autres oublis : par exemple J15 ?
quant à l'ordre des éléments de ta chaine c'est à toi de le vérifier
 
Dernière édition:

tactic6

XLDnaute Impliqué
Re : Longueur ligne de code

Re
tu as tout à fait raison
c'etait encore plein d'oubli
maintenant que tout est modifier ça marche nickel
a tout hasard peut on avec un double clic sur une cellule de la colonne A de la feuil1 recréer la feuille facture correspondante ?
 

kiki29

XLDnaute Barbatruc
Re : Longueur ligne de code

Salut, la réponse est oui, à adapter à ton contexte
Code:
Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range)
Dim Inter As Range, LastRow As Long
Dim i As Long, iRow As Long
Dim sStr As String, Ar() As String

    sStr = "J6,h5,C12,G8,H9,G10,h12,B15,C15,H15,I15,J15,K15," & _
           "B16,C16,H16,I16,K16," & _
           "B17,C17,H17,I17,K17,B18,C18,H18,I18,K18," & _
           "B19,C19,H19,I19,K19,B20,C20,H20,I20,K20,B21,C21,H21,I21,K21," & _
           "B22,C22,H22,I22,K22,B23,C23,H23,I23,K23,B24,C24,H24,I24,K24," & _
           "B25,C25,H25,I25,K25,B26,C26,H26,I26,K26,B27,C27,H27,I27,K27," & _
           "B28,C28,H28,I28,K28,B29,C29,H29,I29,K29,B30,C30,H30,I30,K30," & _
           "B31,C31,H31,I31,K31,B32,C32,H32,I32,K32,B33,C33,H33,I33,K33," & _
           "B34,C34,H34,I34,K34,B35,C35,H35,I35,K35,B36,C36,H36,I36,K36," & _
           "B37,C37,H37,I37,K37,B38,C38,H38,I38,K38,B39,C39,H39,I39,K39," & _
           "B40,C40,H40,I40,K40,B41,C41,H41,I41,K41,B42,C42,H42,I42,K42," & _
           "B43,C43,H43,I43,K43,B44,C44,H44,I44,K44,B45,C45,H45,I45,K45," & _
           "B46,C46,H46,I46,K46,B47,C47,H47,I47,K47,B48,C48,H48,I48,K48," & _
           "B49,C49,H49,I49,K49,B50,C50,H50,I50,K50,B51,C51,H51,I51,K51," & _
           "B52,C52,H52,I52,K52,J54,B55,C55,D55," & _
           "B56,C56,D56,B57,C57,D57,J55,J56,J57,J58,j59"

    Ar = Split(sStr, ",")
    LastRow = ShArchives.Range("A" & Rows.Count).End(xlUp).Row
    Set Inter = Application.Intersect(Target, ShArchives.Range("A2:A" & LastRow))
    If Not Inter Is Nothing Then
        If IsEmpty(Target.Value) Then Exit Sub
        iRow = Target.Row
        ShTest.Cells.Clear
        For i = LBound(Ar) To UBound(Ar)
            ShTest.Range(Ar(i)) = ShArchives.Cells(iRow, i + 1).Value
        Next i
    End If
End Sub
 
Dernière édition:

tactic6

XLDnaute Impliqué
Re : Longueur ligne de code

Bonsoir et encore merci
je me rend compte que c'est loin d'être aussi simple que ça

les premiers messages d'erreur sont des objets non definis
j'ai donc ajouté
Dim ShArchives
Dim ShTest

maintenant et la je ne sais pas c'est
erreur execution 424
objet requis
a la ligne
LastRow = ShArchives.Range("A" & Rows.Count).End(xlUp).Row

je precise que j'ai mis me code dans la feuille qui sert d'archive
Merci
 

skoobi

XLDnaute Barbatruc
Re : Longueur ligne de code

bonjour tout le monde,

pas tout suivi mais en utilisant Union:

Code:
      For Each cellule In Union(.[B15:B32], .[C15:C32], .[H15:H32], .[I15:I32], .[K15:K32], .[J6], .[h5], .[C12], .[G8], .[H9], .[G10], .[h12], .[J54], .[B55:D57], .[J55:J59])

Je pense pas en avoir oublié :eek:.
 

Statistiques des forums

Discussions
312 214
Messages
2 086 313
Membres
103 175
dernier inscrit
abcc