salut! à tous, j'ai un sérieux probleme depuis quelques jours.
je souhaite recupérer des données dans un fichier excel, et le recopier dans un autre. la manipulation se fait sous VB, et ça ne marche pas! je vous fait une copie de mon programme, il est long certe, mais pas compliqué, je compte sur vous!
N.B il marche super bien sous excel, et pas du tout sous VB!
Sub Macro2()
'classe application pour les fichiers contact, protocoles, licences.
Dim app_con As Excel.Application
Dim app_pro As Excel.Application
Dim app_lic As Excel.Application
Dim app_base As Excel.Application
'classe window pour les fichiers contact, protocoles, licences.
Dim fichier_con As Excel.Window
Dim fichier_pro As Excel.Window
Dim fichier_lic As Excel.Window
Dim fichier_base As Excel.Window
'classe worksheet pour les feuilles contact, protocoles, licences.
Dim feuille_con As Excel.Worksheet
Dim feuille_pro As Excel.Worksheet
Dim feuille_lic As Excel.Worksheet
Dim feuille_base As Excel.Worksheet
'classe workbook pour les feuilles contact, protocoles, licences.
Dim classeur_con As Excel.Workbook
Dim calsseur_pro As Excel.Workbook
Dim classeur_lic As Excel.Workbook
Dim classeur_base As Excel.Workbook
'déclaration des directories.
Dim Path_con As String
Dim Path_pro As String
Dim Path_lic As String
Dim path_base As String
'Les différents fichiers contact, protocoles, licences.
Dim fich_con As String
Dim fich_pro As String
Dim fich_lic As String
Dim fich_base As String
'Variables des cellules feuilles contact, protocoles, licences.
Dim cell_lic As Integer
Dim cell_pro As Integer
Dim cell_con As Integer
'Variables offsets contact, protocoles, licences.
Dim off_con As Integer
Dim off_pro As Integer
Dim off_lic As Integer
'Fin des tableaux contact, protocoles, licences.
Dim fin_con As Integer
Dim fin_pro As Integer
Dim fin_lic As Integer
'Variables de la fonction principal.
Dim val_cell As Integer
Dim result As Boolean
'définition des classes excel application comme objet
Set app_con = CreateObject("Excel.application" )
Set app_pro = CreateObject("Excel.application" )
Set app_lic = CreateObject("Excel.application" )
Set app_base = CreateObject("Excel.application" )
'initialisation des fichiers contact, protocoles, licences.
fich_con = "contact.xls"
fich_pro = "protocoles.xls"
fich_lic = "licences.xls"
fich_base = "base_de_données.xls"
'initialisation des directories contact, protocoles, licences.
Path_con = "C:\projet_client\" & fich_con
Path_pro = "C:\projet_client\" & fich_pro
Path_lic = "C:\projet_client\" & fich_lic
path_base = "C:\projet_client\" & fich_base
'définition des classes workbook contact, protocoles, licences
Set classeur_con = app_con.Workbooks.Open(Path_con)
Set classeur_pro = app_pro.Workbooks.Open(Path_pro)
Set classeur_lic = app_lic.Workbooks.Open(Path_lic)
Set classeur_base = app_base.Workbooks.Open(path_base)
'initialisation du contenu des cellules du fichier principal et la fin des différents tableaux
val_cell = 2
fin_con = 5
fin_pro = 27
fin_lic = 13
'Initialisation de l'offset, et de la fin du contenu du fichier contact
off_con = 0
off_pro = 0
off_lic = 0
'Identification du fichier actif.
Set fichier_base = app_base.Windows(fich_base)
fichier_base.Activate
Set feuille_base = app_base.Sheets("Récapitulatif" )
feuille_base.Activate
'Test des différents champs avec avec "ou". si ligne remplie, passage à la ligne suivante.
Do
result = CBool(Range("B" & Asc(val_cell)).Value) Or CBool(Range("C" & Asc(val_cell)).Value) Or CBool(Range("D" & val_cell).Value)
If result = False Then
'Remplissage des champs contact.
For cell_con = 1 To fin_con
Set fichier_con = app_con.Windows(fich_con)
fichier_con.Activate
Set feuille_con = app_con.Sheets("contact" )
feuille_con.Range("B" & cell_con).Cut
fichier_base.Activate
Range("B" & val_cell).Activate
ActiveCell.Offset(0, off_con).Select
ActiveSheet.Paste
feuille_con.Range("B" & cell_con).Clear
off_con = off_con + 1
Next cell_con
'Sauvegarde et fermeture du fichier contact.
app_con.Workbooks(fich_con).Save
app_con.Workbooks(fich_con).Close
'Remplissage des champs protocoles.
For cell_pro = 1 To fin_pro
Set fichier_pro = app_pro.Windows(fich_pro)
fichier_pro.Activate
Set feuille_pro = app_pro.Sheets("protocoles" )
feuille_pro.Range("B" & cell_pro).Cut
fichier_base.Activate
Range("G" & val_cell).Activate
ActiveCell.Offset(0, off_pro).Select
ActiveSheet.Paste
feuille_pro.Range("B" & cell_pro).Clear
off_pro = off_pro + 1
Next cell_pro
'Sauvegarde et fermeture du fichier protocoles.
app_pro.Workbooks(fich_pro).Save
app_pro.Workbooks(fich_pro).Close
fichier_base.Activate
If Range("A" & val_cell).Value = "" Then
For cell_lic = 1 To fin_lic
Set fichier_lic = app_lic.Windows(fich_lic)
fichier_lic.Activate
Set feuille_lic = app_lic.Sheets("licences" )
feuille_lic.Range("B" & cell_lic).Cut
fichier_base.Activate
Range("A" & val_cell).Activate
ActiveCell.Offset(off_lic, 0).Select
ActiveSheet.Paste
off_lic = off_lic + 2
Next cell_lic
'Sauvegarde et fermeture du fichier licences.
app_lic.Workbooks(fich_lic).Save
app_lic.Workbooks(fich_lic).Close
End If
Else: Range("B" & val_cell + 2).Activate
End If
val_cell = val_cell + 2
Loop While result = True
End Sub
![[:kiki]](https://forum-images.hardware.fr/images/perso/kiki.gif "[:kiki]")