compatibiliter

Question

voila j'ai deja poser cette question masi comme je n'ai pas eu de complement de reponse je recommence

je doit faire tourner un prog vb (macro excel a l'origine transformer pour des raison pratique en VB)

j'utilise vb6 (sp6) et la macro etait faite pour excel XP a l'origne.
mais maintenant je doit faire tourner mon prog pour un excel 2000 et la librairie n'est pas la meme. comment faire je vous met le code a la fin de la question.

code principal : 


Option Explicit
Public OldWidth As Long
Public OldHeight As Long
Public appExcel As Excel.Application
Public docExcel As Workbook
Public feuilleExcelTri As Worksheet
Public feuilleExcel As Worksheet
Dim chemin As String
Dim fichier As String
Dim cpt As Integer
Dim i As Integer

Private Sub Cmd3_Click()
'Set docExcel = appExcel.Workbooks("Fichier_Reference_MaJ_Airbus")
Set feuilleExcel = appExcel.Worksheets("Workstations with SMS Installed")
Set feuilleExcelTri = appExcel.Worksheets("TriSuppressionDoublon")

Application.DisplayAlerts = False
feuilleExcelTri.Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

chemin = "G:"
fichier = "AIRBUS-RCS-IS_" & Format(Date, "yyyymmdd")
On Error GoTo fin
docExcel.SaveAs (chemin & fichier)
fin:
Unload Me
End Sub

Private Sub Command1_Click()

Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True

fichier = "G:\Fichier_Reference_MaJ_Airbus\Fichier_Reference_MaJ_Airbus.xls"

Set docExcel = appExcel.Workbooks.Open(fichier)
 'Set docExcel = appExcel.Workbooks.open.Filename:=fichier
Set feuilleExcelTri = docExcel.Worksheets("TriSuppressionDoublon")
Set feuilleExcel = docExcel.Worksheets("Workstations with SMS Installed")
End Sub

Private Sub Command2_Click()
'On Error GoTo messageErreur
'Set docExcel = appExcel.Workbooks("Fichier_Reference_MaJ_Airbus")
Set feuilleExcel = appExcel.Worksheets("Workstations with SMS Installed")
Set feuilleExcelTri = appExcel.Worksheets("TriSuppressionDoublon")

appExcel.ScreenUpdating = True

Dim MaCell As Excel.Range
Dim MaCellSuite As Excel.Range
Dim celUn As Excel.Range
Dim celDeux As Excel.Range
Dim celTrois As Excel.Range
Dim fin As Variant

cpt = 0

feuilleExcelTri.Range("B1").Sort _
key1:=feuilleExcelTri.Range("B2"), _
Order1:=xlAscending, Header:=xlGuess
 

Set MaCell = feuilleExcelTri.Range("B1")

 
Do While Not IsEmpty(MaCell)
Set MaCellSuite = MaCell.Offset(1, 0)
If MaCellSuite.Value = MaCell.Value Then
MaCell.EntireRow.Delete
End If
Set MaCell = MaCellSuite
Loop

With feuilleExcel
.Select
.Columns("E:E").Insert
.Columns("F:F").Insert
End With

Sheets("TriSuppressionDoublon").Select
    Range("C1").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = ""
    Range("B1:B2000").Select
    Selection.Copy
    Sheets("Workstations with SMS Installed").Select
    Range("F7").Select
    ActiveSheet.Paste
 
Set celUn = feuilleExcel.Range("A7")
Set celDeux = feuilleExcel.Range("D7")
Set celTrois = feuilleExcel.Range("F7")

'on  parcourt toutes les lignes
For i = 1 To feuilleExcel.Range("A7").CurrentRegion.Rows.Count '- 1
    'si les trois cellules ne sont pas égales :
    'on recherche la présence du A dans D (s'il n'y est pas on supprime)
    'on recherche la présence du D dans A (s'il n'y est pas on ajoute)
    'si A = D alors on décale F d'une ligne    If Not (celUn celDeux And celDeux celTrois) Then
  '*********************************************
        'recherche de A dans D
        'si A n'existe pas dans D --> suppression de A
        If celUn = celDeux And Not IsEmpty(celTrois) Then GoTo decaleF
        If ModRecherche.rechercheA(celUn, celDeux) = False Then
            'on prend toutes les lignes jusqu'à la fin sur les 3 colonnes
            'et on les remonte d'une case
            fin = celUn.CurrentRegion.Rows.Count
            feuilleExcel.Range(celUn.Offset(1, 0).Address & ":" & celUn.Offset(fin, 2).Address).Select
            Excel.Selection.Cut
            celUn.Select
            feuilleExcel.Paste
            Set celUn = celDeux.Offset(0, -3)
            GoTo Suite
        End If

        '*********************************************
        '*********************************************

        'recherche de D dans A
        'si D n'existe pas dans A --> insertion de D
        If ModRecherche.rechercheD(celUn, celDeux) = False Then
            'on décale A,B et C d'une ligne
            fin = celUn.CurrentRegion.Rows.Count
            feuilleExcel.Range(celUn.Address & ":" & celUn.Offset(fin, 2).Address).Select
            Excel.Selection.Cut
            celUn.Offset(1, 0).Select
            feuilleExcel.Paste

            Set celUn = celDeux.Offset(0, -3)
            'on insère le nouveau D
            celUn = celDeux.Value
            celUn.Offset(0, 1) = ""
            celUn.Offset(0, 2) = ""
            GoTo Suite

        End If

        '*********************************************
        'si A existe dans D et D existe dans A alors on décale F d'une ligne

decaleF:
        fin = celTrois.CurrentRegion.Rows.Count
        feuilleExcel.Range(celTrois.Address & ":" & celTrois.Offset(fin, 0).Address).Select
        Excel.Selection.Cut
        celTrois.Offset(1, 0).Select
        feuilleExcel.Paste
        Set celTrois = celUn.Offset(0, 5)

    Else
    '--------------SI A D F alors on recherche la Date ----------------'
        celUn.Offset(0, 2) = ModRecherche.rechercheDate(celUn)
    '----------------------------------------------------------------------'
    End If

Set celUn = celUn.Offset(1, 0)
Set celDeux = celDeux.Offset(1, 0)
Set celTrois = celTrois.Offset(1, 0)

Suite:

Next i

appExcel.ScreenUpdating = True

 
Dim cellule As Excel.Range
Set cellule = feuilleExcel.Range("A7")
While Not IsEmpty(cellule)
If Not IsEmpty(cellule.Offset(0, 5)) Then cpt = cpt + 1
Set cellule = cellule.Offset(1, 0)
Wend
'MsgBox "celUn : " & celUn.Address & ", celDeux : " & celDeux.Address & ", celTrois : " & celTrois.Address
compteur.Text = cpt

 Columns("D:F").Select
 Selection.Delete Shift:=xlToLeft
 ActiveWindow.ScrollColumn = 2
 ActiveWindow.ScrollColumn = 3
 ActiveWindow.ScrollColumn = 4
 ActiveWindow.ScrollColumn = 5
 ActiveWindow.ScrollColumn = 6
 ActiveWindow.ScrollColumn = 7
 Columns("L:M").Select
 Selection.Cut
 ActiveWindow.ScrollColumn = 6
 ActiveWindow.ScrollColumn = 5
 ActiveWindow.ScrollColumn = 4
 ActiveWindow.ScrollColumn = 3
 ActiveWindow.ScrollColumn = 2
 Columns("D:E").Select
 ActiveSheet.Paste

Exit Sub

messageErreur:
Dim reponse As String
reponse = MsgBox(" Vous ne pouver pas lancer le tri si vous n'ouver pas excel." & vbCrLf & "" & vbCrLf & "Voulez-vous ouvrir Excel ?", 308, "Attention")
If reponse = vbYes Then
Call Command1_Click
 Else
 Unload Me
End If
 
End Sub

Private Sub Form_Load()
OldWidth = Width
OldHeight = Height
End Sub

Private Sub Form_Resize()
On Error Resume Next
Dim XCoeff As Single
Dim YCoeff As Single
Dim Controle As Control
XCoeff = Width / OldWidth
YCoeff = Height / OldHeight
For Each Controle In Me
Controle.Move Controle.Left * XCoeff, Controle.Top * YCoeff, Controle.Width * XCoeff, Controle.Height * YCoeff

Next
OldWidth = Width
OldHeight = Height
End Sub

Private Sub compteur_Change()
Form1.compteur.Text = cpt
End Sub



modules relatif au code 


Option Explicit
Dim i As Integer

'******************Fonction de recherche de A dans D *****************'

Function rechercheA(ByVal celUnBis As Excel.Range, ByVal celDeuxBis As Excel.Range) As Boolean

Dim cherche As Boolean
cherche = False
For i = 1 To celDeuxBis.CurrentRegion.Rows.Count - 1    If celUnBis celDeuxBis Then cherche True
    Set celDeuxBis = celDeuxBis.Offset(1, 0)
Next iIf (cherche) Then rechercheA True Else rechercheA False
End Function

'******************Fonction de recherche de D dans A *****************'

Function rechercheD(ByVal celUnBis As Excel.Range, ByVal celDeuxBis As Excel.Range) As Boolean
Dim cherche As Boolean
cherche = False
For i = 1 To celUnBis.CurrentRegion.Rows.Count - 1    If celDeuxBis celUnBis Then cherche True
    Set celUnBis = celUnBis.Offset(1, 0)
Next iIf (cherche) Then rechercheD True Else rechercheD False
End Function

'******************Fonction de recherche de la date *****************'
Function rechercheDate(ByVal cel As Excel.Range) As String
Dim cherche As Boolean
Dim celRecherche As Range
'Set Form1.docExcel = Form1.appExcel.Workbooks("Fichier_Reference_MaJ_Airbus")
'Set Form1.feuilleExcelTri = Form1.docExcel.Worksheets("TriSuppressionDoublon")
'Set Form1.feuilleExcel = Form1.docExcel.Worksheets("Workstations with SMS Installed")
cherche = False
Set celRecherche = Form1.feuilleExcelTri.Range("B1")
While Not IsEmpty(celRecherche) And cherche = False
    If celRecherche.Value = cel.Value Then
        cherche = True
        GoTo stopRecherche
    End If
    Set celRecherche = celRecherche.Offset(1, 0)
Wend
stopRecherche:
rechercheDate = celRecherche.Offset(0, -1).Value
End Function

gaa179 · Answer

Salut,

Pour ne pas dépendre de la version d'Excel, tu peux utiliser la méthode suivant.
A la place de:
Public appExcel As Excel.Application
Public docExcel As Workbook
Public feuilleExcelTri As Worksheet
Public feuilleExcel As Worksheet

Tu crées:
Public appExcel As Object
Public docExcel As Object
Public feuilleExcelTri As Object
Public feuilleExcel As Object

Ensuite tu dois initialiser les Objects dans une procédure
Set appExcel = CreateObject("Excel.Apllication")
Set docExcel = CreateObject("Excel.Workbook")
Set feuilleExcelTri = CreateObject("Excel.Worksheet")
Set feuilleExcel = CreateObject("Excel.Worksheet")

Ainsi tu ne dépend plus de la version d'Excel installé. Il faut juste que les propriétées et fonction existent et soient au même endroit dans les différentes versions.

A+

cs_lu6fer · Answer

et pour la mes initialisations de feuille (Set feuilleExcel = appExcel.Worksheets("Workstations with SMS Installed"))
je fait comment
car il fau que je les gardes mais si je l'ai met apres les Set feuilleExcel = CreateObject("Excel.Worksheet")
je ne c pas si sa va marcher
en tout cas merci pour cette reponse

gaa179 · Answer

Rien ne change pour la suite de ton code.
Si tu fais Dim var as Exce.workbook, tu utilise une librairie référencée en VB. Si tu fait Dim var as object, puis Set var = CreateObject("Excel.Workbook"), tu utilise directement la classe Excel.Workbook sans la référencé en VB.Le résultat est le même.Pour le reste, c'est inchangé(sauf que les propriétés, méthodes n'apparaissent plus après le point.

A+

gaa179 · Answer

Sorry correction.

Tu ne définit que appExcel et tu ne set pas les autres Objets.

Donc
Public appExcel As Object
Public docExcel As Object
Public feuilleExcelTri As Object
Public feuilleExcel As Object

Ensuite tu dois initialiser les Objects dans une procédure
Set appExcel = CreateObject("Excel.Apllication")

cs_lu6fer · Answer

depuis que j'ai remplacer le code et decocher la reference VB me trouve des erreurs au niveau de FonctionRechercheA...
es ce que cela peu venir de ca???

gaa179 · Answer

Oui,

Pour tes fonctions tu passes comme paramètres des object Excel.Range qui ne sont plus connus; Remplace Excel.Range par Object et réessaie

cs_lu6fer · Answer

je vien de voir une erreur ici Order1:=xlAscending, Header:=xlGuess il me met variable non defini mais comment definir ca ?? si tu voi quel que chose
merci d'avance

gaa179 · Answer

Ce sont des constantes définies dans la libraire D'Excel. Soit tu recrées les constantes  ou alors tu pla ce les valeurs.
Pour connaître les valeurs, réactive la référence Excel, appuye sur [F2] (browse) et sélectionne la libraire Excel. Tout pourras trouver les constantes et lorsqu'elles sont sélectionnées, la valeur s'affichage dans le bas de la fenêtre.

A+

Compatibiliter

8 réponses