Re : [demande d'aide]Dissociation de liste en plusieurs onglets
J'ai continué mes investigations, ça ne vient pas des balises <br/>
Si je raccourcis la description (je vais m'adapter, il n' y a plus de bug 1004 mais un nouveau apparait: les onglets sont tous créés mais seul une ligne est transférée...
Je ne capte plus rien quand il y a trois colonnes à copier en critère tout passe, si j'en met 4 ça plante
J'ai pensé que c'était lié aux types de données:
J'ai fait un copier coller des valeurs de tout le tableau résultat => pareil
Je me suis dit que c'était peut être une colonne ou deux qui coince....
Je garde mes trois colonnes à copier, je laisse les communes en tant que critère de sélection => pas de souci , le système de tri marche uniquement avec 3 colonnes quelque soit ce que j'ai mis à l'intérieur (je change les contenus, ce n'est donc pas lié au formatage, ou au case vide)
Quand je met que la table contient 2 colonnes ça plante aussi => il doit y avoir un paramètre dans la v2 / v3 v4 qui fait que ça coince sur ces trois colonnes (le code initial étant prévu pour trois colonnes peut être ? )
J'épluche maintenant le code du truc et je trouve pas l'origine du problème
Option Explicit
Private Const Col As Long = 3 '<==== Colonne ou se trouve le discriminant
Private Const c As Long = 3 '<==== NB. de colonnes à traiter
Private Const En_Tete As Boolean = True '<==== Prendre en compte les en têtes True = Oui, False = Non
Private Sub CommandButton1_Click()
Load UserForm1
UserForm1.Show
Unload UserForm1
End Sub
Private Function toto(sh As Worksheet)
Dim i&, dDat(), dat(), oColl As New Collection
dDat = Array()
On Error Resume Next
With sh
For i = 1 + IIf(En_Tete = True, 1, 0) To .Cells(.Rows.Count, Col).End(xlUp).Row
If .Cells(i, Col).Value <> "" Then
oColl.Add CStr(.Cells(i, Col).Value), CStr(.Cells(i, Col).Value)
End If
Next
End With
On Error GoTo 0
ReDim dDat(oColl.Count - 1)
For i = 1 To oColl.Count: dDat(i - 1) = Array(oColl(i), dat): Next
toto = dDat
End Function
Sub tata(x$)
Dim i&, j&, k&, m&, s$, dDat(), oDat, dat(), F As Worksheet
Set F = Sheets("Tous") '<==== Nom de la feuille portant la liste
dDat = toto(F)
If dDat(0)(0) = "" Then Exit Sub
With F
For i = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If .Cells(i, Col).Value <> "" Then
s = CStr(.Cells(i, Col).Value)
For j = 0 To UBound(dDat)
If dDat(j)(0) = s Then
oDat = dDat(j)(1)
m = 0
On Error Resume Next
m = 1 + UBound(oDat, c - 1)
On Error GoTo 0
ReDim Preserve oDat(0 To c - 1, 0 To m)
For k = 1 To c: oDat(k - 1, m) = Cells(i, k): Next
dDat(j)(1) = oDat
End If
Next j
End If
Next i
With Application: .ScreenUpdating = 0: .Calculation = -4135: .EnableEvents = 0: End With
For j = 0 To UBound(dDat)
On Error GoTo 0
oDat = dDat(j)(1)
On Error GoTo NF
With Sheets(dDat(j)(0))
If x = "Remplacer" Then
.[A1].CurrentRegion.ClearContents
If En_Tete = True Then .Rows(1).Value = Sheets("Tous").Rows(1).Value
End If
.Cells(.Rows.Count, 1).End(xlUp).Offset(1 + IsEmpty(.[A1]), 0).Resize(UBound(oDat, 2) + 1, c).Value = WorksheetFunction.Transpose(oDat)
.Columns(1).Resize(, c).Columns.AutoFit
End With
Next
.Activate
End With
With Application: .EnableEvents = 1: .Calculation = -4105: .ScreenUpdating = 1: End With
Exit Sub
NF:
Sheets.Add After:=Sheets(IIf(j, dDat(j + (j <> 0))(0), Me.Name))
With ActiveSheet
.Name = dDat(j)(0)
Debug.Print dDat(j)(0)
If En_Tete = True Then .Rows(1).Value = Sheets("Tous").Rows(1).Value
End With
Resume
End Sub
J'ai pensé que ça pouvait venir d'une inversion quelque part dans le code entre les variables Col et C mais même en m'arrangeant pour que Col et C soient égales => ça marche pas
