Problème collage presse papier

[Bigboss60]

Bonjour,

J'ai fais une macro qui va chercher des données contenu dans mon presse papier. Ces données sont issues de mon logiciel de comptabilité et je veux sélectionner une date mini par exemple le 01/09/2007 et le tri ne se fait pas. Il me prend toute les dates depuis 2005.

Voici ma macro:


Sub IntegrationEcrituresStandard()

' Importe des Ecritures COALA (venant du presse-papier) dans l'onglet 'Ecritures'
' Methode: Cree une page vierge, y colle le presse papier
' Puis fais le traitement d'importation Coala
' Enfin, on supprime la page et on envoie les ecritures dans la balance

Dim FeuilEcrit As String
Dim FeuilNew As String
Dim FeuilNewEX As String
Dim NbLig As Integer
Dim i As Integer
Dim j As Integer
Dim jEX As Integer

'Demande la date Mini
LaDate = inputbox("Date de debut des ecritures à recuperer" & Chr(13) & "Format: JJ/MM/AAAA")

'Cree une feuille vide et colle le presse papier dedans

Sheets.Add
ActiveSheet.Paste

' Retire les virgules sur les colonnes J et K
Selection.Find(What:=",", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.FindNext(After:=ActiveCell).Activate
Selection.FindNext(After:=ActiveCell).Activate
Cells.Replace What:=",", Replacement:="", LookAt:=xlPart, SearchOrder:= _
xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False

'Modification des dates de comptabilisation pour Hibgest
Dim t As Single
Dim datecopie As Date
datecopie = inputbox("Entrez une date de comptabilisation des écritures dans Hibgest")
t = 1
Do While Cells(t, 3).Value <> ""
Cells(t, 1).Value = datecopie
t = t + 1
Loop

'Recupere le nom de la nouvelle feuille
FeuilEcrit = ActiveSheet.Name

'Compte le nombre de lignes à importer
NbLig = 0
Do While (Worksheets(FeuilEcrit).Range("A" & (NbLig + 1)) <> "")
NbLig = NbLig + 1
Application.StatusBar = "Calcul des lignes à importer : " & NbLig
Loop

'Teste le nombre de lignes
If NbLig = 0 Then
Application.StatusBar = False
MsgBox "Le fichier à importer ne contient pas de ligne."
Exit Sub
End If

'Ajoute une feuille pour les ecritures Standard
Sheets.Add

'Recupere le nom de la nouvelle feuille
ActiveSheet.Name = "Autres"
FeuilNew = ActiveSheet.Name

'Ajoute une feuille pour les ecritures Standard
Sheets.Add

'Recupere le nom de la nouvelle feuille
ActiveSheet.Name = "EX"
FeuilNewEX = ActiveSheet.Name

'Formate le nouvel Onglet pour les ecritures standard
j = 0
jEX = 0
For i = 1 To NbLig
'Worksheets(FeuilEcrit).Range("A" & (i)) >= LaDate
If DateDiff("d", Worksheets(FeuilEcrit).Range("A" & (i)), LaDate) <= 0 And UCase(Left(Worksheets(FeuilEcrit).Range("B" & (i)), 3)) <> "BAL" Then
If UCase(Left(Worksheets(FeuilEcrit).Range("B" & (i)), 2)) = "EX" Or UCase(Left(Worksheets(FeuilEcrit).Range("B" & (i)), 2)) = "ES" Then
jEX = jEX + 1
Worksheets(FeuilNewEX).Range("A" & (jEX)) = "Hib"
Worksheets(FeuilNewEX).Range("B" & (jEX)) = 1
Worksheets(FeuilNewEX).Range("C" & (jEX)) = Right(Worksheets(FeuilEcrit).Range("I" & (i)), 2)
Worksheets(FeuilNewEX).Range("D" & (jEX)) = "96" 'Left(Worksheets(FeuilEcrit).Range("B" & (i)), 2)
Worksheets(FeuilNewEX).Range("E" & (jEX)) = Left(Worksheets(FeuilEcrit).Range("A" & (i)), 2) & Mid(Worksheets(FeuilEcrit).Range("A" & (i)), 4, 2) & Right(Worksheets(FeuilEcrit).Range("A" & (i)), 2)
Worksheets(FeuilNewEX).Range("G" & (jEX)) = Worksheets(FeuilEcrit).Range("C" & (i))
If Left(Worksheets(FeuilEcrit).Range("C" & (i)), 2) = "40" Or Left(Worksheets(FeuilEcrit).Range("C" & (i)), 2) = "41" Then
Worksheets(FeuilNewEX).Range("F" & (jEX)) = Worksheets(FeuilEcrit).Range("D" & (i))
Worksheets(FeuilNewEX).Range("H" & (jEX)) = Worksheets(FeuilEcrit).Range("D" & (i))
Else
Worksheets(FeuilNewEX).Range("H" & (jEX)) = CStr(Val(Worksheets(FeuilEcrit).Range("E" & (i + 1))))
If Worksheets(FeuilNewEX).Range("H" & (jEX)) = "0" Then
Worksheets(FeuilNewEX).Range("H" & (jEX)) = ""
End If
End If
Worksheets(FeuilNewEX).Range("I" & (jEX)) = Worksheets(FeuilEcrit).Range("E" & (i))
Worksheets(FeuilNewEX).Range("J" & (jEX)).Value = CStr(Val(Worksheets(FeuilEcrit).Range("F" & (i))) / 1000)
Worksheets(FeuilNewEX).Range("K" & (jEX)).Value = CStr(Val(Worksheets(FeuilEcrit).Range("G" & (i))) / 1000)
Worksheets(FeuilNewEX).Range("F" & (jEX)).Value = "20" & Right(Worksheets(FeuilEcrit).Range("A" & (i)), 2) & Mid(Worksheets(FeuilEcrit).Range("A" & (i)), 4, 2) & Left(Worksheets(FeuilEcrit).Range("A" & (i)), 2)
Else
j = j + 1
Worksheets(FeuilNew).Range("A" & (j)) = "Hib"
Worksheets(FeuilNew).Range("B" & (j)) = 1
Worksheets(FeuilNew).Range("C" & (j)) = Right(Worksheets(FeuilEcrit).Range("I" & (i)), 2)
Worksheets(FeuilNew).Range("D" & (j)) = "40" 'Left(Worksheets(FeuilEcrit).Range("B" & (i)), 2)
Worksheets(FeuilNew).Range("E" & (j)) = Left(Worksheets(FeuilEcrit).Range("A" & (i)), 2) & Mid(Worksheets(FeuilEcrit).Range("A" & (i)), 4, 2) & Right(Worksheets(FeuilEcrit).Range("A" & (i)), 2)
Worksheets(FeuilNew).Range("G" & (j)) = Worksheets(FeuilEcrit).Range("C" & (i))
If Left(Worksheets(FeuilEcrit).Range("C" & (i)), 2) = "40" Or Left(Worksheets(FeuilEcrit).Range("C" & (i)), 2) = "41" Then
Worksheets(FeuilNew).Range("F" & (j)) = Worksheets(FeuilEcrit).Range("D" & (i))
Worksheets(FeuilNew).Range("H" & (j)) = Worksheets(FeuilEcrit).Range("D" & (i))
Else
Worksheets(FeuilNew).Range("H" & (j)) = CStr(Val(Worksheets(FeuilEcrit).Range("E" & (i + 1))))
If Worksheets(FeuilNew).Range("H" & (j)) = "0" Then
Worksheets(FeuilNew).Range("H" & (j)) = ""
End If
End If
Worksheets(FeuilNew).Range("I" & (j)) = Worksheets(FeuilEcrit).Range("E" & (i))
Worksheets(FeuilNew).Range("J" & (j)) = CStr(Val(Worksheets(FeuilEcrit).Range("F" & (i))) / 1000)
Worksheets(FeuilNew).Range("K" & (j)) = CStr(Val(Worksheets(FeuilEcrit).Range("G" & (i))) / 1000)
Worksheets(FeuilNew).Range("F" & (j)).Value = "20" & Right(Worksheets(FeuilEcrit).Range("A" & (i)), 2) & Mid(Worksheets(FeuilEcrit).Range("A" & (i)), 4, 2) & Left(Worksheets(FeuilEcrit).Range("A" & (i)), 2)
End If
End If
Next i

'Supprime l'onglet crée
Application.DisplayAlerts = False
Sheets(FeuilEcrit).Delete
Application.DisplayAlerts = True
Application.StatusBar = False

'Alignement des colonnes montant et séparation des journaux
Columns("J:K").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.LargeScroll ToRight:=-1
Range("A1").Select
Sheets("Autres").Select
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
Columns("J:K").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Sheets("Autres").Select
Sheets("Autres").Move

End Sub

 

[porcinet82]

Re : Problème collage presse papier

Salut,

Je me permet de te répondre sans t'apporter de solution car a mon avis, les propositions ne vont pas pleuvoir du fait de la taille de ton code qui je pense fait un peut peur aux gens...

Je pense qu'un exemple de ton fichier (sans données confidentielles) serait beaucoup plus parlant et permettrait de tester directement le code sans devoir créer un fichier, chose qui necessite de déchiffrer auparavant le code.

@+