Macro sous Excel 2003 qui BUG avec Excel2010
Bonjour forum,
voilà déjà quelques années, on m'a construit une macro qui transpose des données disposées en collone dans un feuillet vers
2 autres feuillets mais cette fois, disposées sur des lignes. Alors que la macro fonctionnait bien avec mon vieil ordi et
sous Excel 2003, voilà que maintenant la macro "bug". Le problème semble provenir du fait que le filtrage (selon les dates)
ne semble plus être bien compris, ce qui fait planter la macro par la suite. Voilà la macro:
Sub Pluie_Neige_Tranpose()
' Macro enregistrée le 2012-11-19
Dim J As Long, Ligne As Long, NbLig As Long
Dim I As Integer, K As Integer, Colonne As Integer
Dim Mondico As Object
Dim Ws(2) As Worksheet
Dim Tablo
Dim Cel As Range, Cel1 As Range
Application.ScreenUpdating = False
Set Ws(0) = Sheets("Pluie")
Set Ws(1) = Sheets("Neige")
Set Ws(2) = Sheets("Tous")
If Ws(2).AutoFilterMode = True Then Ws(2).AutoFilterMode = False
NbLig = Ws(2).Range("A" & Rows.Count).End(xlUp).Row
Ws(0).Cells.ClearContents
Ws(1).Cells.ClearContents
Ws(0).Range("A1:F1") = Array("ID", "Nom de la station", "Rgn", "Lat", "Lon", "Elevation")
Ws(1).Range("A1:F1") = Array("ID", "Nom de la station", "Rgn", "Lat", "Lon", "Elevation")
' Création d'une liste des dates uniques
Set Mondico = CreateObject("Scripting.dictionary")
For J = 2 To NbLig
Mondico(Ws(2).Range("G" & J).Value) = ""
Next J
Ws(0).Range("G1").Resize(1, Mondico.Count) = Mondico.keys
Ws(1).Range("G1").Resize(1, Mondico.Count) = Mondico.keys
Colonne = 7 ' Colonne de reception des 1ères données
Tablo = Mondico.keys
For I = 0 To UBound(Tablo) ' Pour toutes les dates ' Filtre les données
Ws(2).Range("A1:O" & NbLig).AutoFilter Field:=7, Criteria1:=DateValue(Tablo(I))
' Pour chaque résultat
For Each Cel In Ws(2).Range("A2:A" & NbLig).SpecialCells(xlCellTypeVisible)
For K = 0 To 1 ' Dans les 2 feuilles
' Recherche si l'ID existe
Set Cel1 = Ws(K).Columns("A").Find(what:=Cel, LookIn:=xlValues, lookat:=xlWhole)
If Not Cel1 Is Nothing Then
Ligne = Cel1.Row ' ID existe
Else ' Id n'existe pas on le crée
Ligne = Ws(K).Range("A" & Rows.Count).End(xlUp).Row + 1
Ws(2).Range("A" & Cel.Row).Resize(1, 6).Copy Ws(K).Range("A" & Ligne)
End If
' On copie l'information correspondante
Ws(K).Cells(Ligne, Colonne) = Cel.Offset(0, 9 + K) '9 pour copier 10 et 11ième col.
'Dans le feuillet: "Pluie"
'If K = 0 And IsNumeric(Ws(K).Cells(Ligne, Colonne)) And Ws(K).Cells(Ligne, Colonne) >= 25 And Ws(K).Cells(Ligne, Colonne) < 50 Then
' Ws(K).Cells(Ligne, Colonne).Interior.Color = 65535 'on colore jaune: cellules entre 25 et 50
' End If
'If K = 0 And IsNumeric(Ws(K).Cells(Ligne, Colonne)) And Ws(K).Cells(Ligne, Colonne) >= 50 Then
' Ws(K).Cells(Ligne, Colonne).Interior.Color = 255 'on colore rouge: cellules >= 50
'End If
'Dans le feuillet: "Neige"
' If K = 1 And IsNumeric(Ws(K).Cells(Ligne, Colonne)) And Ws(K).Cells(Ligne, Colonne) >= 10 And Ws(K).Cells(Ligne, Colonne) < 15 Then
' Ws(K).Cells(Ligne, Colonne).Interior.Color = 65535 'on colore jaune: cellules entre 10 et 15
'End If
'If K = 1 And IsNumeric(Ws(K).Cells(Ligne, Colonne)) And Ws(K).Cells(Ligne, Colonne) >= 15 Then
' Ws(K).Cells(Ligne, Colonne).Interior.Color = 255 'on colore rouge: cellules >= 15
'End If
'End If
Next K
Next Cel
Colonne = Colonne + 1 ' La prochaine date filtrée ira dans cette colonne
Next I
Ws(2).AutoFilterMode = False
End Sub
Quelqu'un a un idée pour résoudre le problème?
Je fournis un fichier simplifié.
En vous remerciant d'avance
Émil
bonjour,
ton classeur ne donne pas de problème avec ma version 2010 UK.
Bonjour H2SO4,
il est bien possible que le problème soit aussi lié au faut que j'ai une version Canadien anglaise autant pour Excel. D'autre part, je me demande si le tout n'est pas lié à ma config (sous Window 7). Y-at'il moyen de filtrer autrment que par les dates ?
Emil
Bonjour
Remplace ton filtre par celui-ci
Ws(2).Range("A1:O" & NbLig).AutoFilter Field:=7, Criteria1:=">=" & CSng(Tablo(I)), Operator:=xlAnd, Criteria2:="<=" & CSng(Tablo(I))
Pas de plantage avec XL 2003 FR ni avec XL 2010 FR
Bonjour Banzai64,
j'ai modifié la macro tel que prescrit et tout fonctionne à merveille!
Je vous remercie.
Émil