Problème de liaison entre classeurs
Fermé
biboupifa
Messages postés
54
Date d'inscription
mardi 11 juin 2013
Statut
Membre
Dernière intervention
19 juillet 2013
-
18 juil. 2013 à 12:47
biboupifa Messages postés 54 Date d'inscription mardi 11 juin 2013 Statut Membre Dernière intervention 19 juillet 2013 - 18 juil. 2013 à 16:44
biboupifa Messages postés 54 Date d'inscription mardi 11 juin 2013 Statut Membre Dernière intervention 19 juillet 2013 - 18 juil. 2013 à 16:44
A voir également:
- Problème de liaison entre classeurs
- Bord gauche a été en liaison de document en raison d'un conflit avec un autre paramètre d'imprimante - Forum Imprimante
- Acheminé sur une liaison internationale - Forum Vos droits sur internet
- Copier coller vba excel entre 2 classeurs ✓ - Forum VB / VBA
- Excel liaison avec un autre classeur fermé ✓ - Forum Excel
- Fusionner deux classeurs excel - Guide
3 réponses
biboupifa
Messages postés
54
Date d'inscription
mardi 11 juin 2013
Statut
Membre
Dernière intervention
19 juillet 2013
Modifié par biboupifa le 18/07/2013 à 12:55
Modifié par biboupifa le 18/07/2013 à 12:55
Sub Ouvre_ts_les_classeurs()
' Ouvre tous les fichiers excel contenus dans un répertoire.
'
Dim Système As Object 'Système de fichiers
Dim Dossier As Object 'Répertoire
Dim Fichiers As Object 'Collection de fichiers du répertoire
Dim Fichier As Object 'Fichier (élément de la collection Fichiers)
Dim Nom_Dossier As String 'Nom du répertoire
Dim Nom_Fichier As String 'Nom du fichier
'Lecture du répertoire COMMANDE
Nom_Dossier = "Y:\Service Expedition\pierre-alexis.bernard\Profils Clients\Commande"
Set Système = CreateObject("Scripting.FileSystemObject")
Set Dossier = Système.GetFolder(Nom_Dossier)
Set Fichiers = Dossier.Files
'Contrôler chaque fichier du répertoire
For Each Fichier In Fichiers
'- Vérifier s'il s'agit d'un fichier Excel...
If StrComp(Système.GetExtensionName(Fichier.Name), "csv", vbTextCompare) = 0 Then
'... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
Nom_Fichier = Nom_Dossier & "\" & Fichier.Name
Workbooks.OpenText Filename:=Nom_Fichier, DataType:=1, Semicolon:=True, local:=True
End If
Next Fichier
'Lecture du répertoire EXPEDITION
Nom_Dossier = "Y:\Service Expedition\pierre-alexis.bernard\Profils Clients\Expédition"
Set Système = CreateObject("Scripting.FileSystemObject")
Set Dossier = Système.GetFolder(Nom_Dossier)
Set Fichiers = Dossier.Files
'Contrôler chaque fichier du répertoire
For Each Fichier In Fichiers
'- Vérifier s'il s'agit d'un fichier Excel...
If StrComp(Système.GetExtensionName(Fichier.Name), "csv", vbTextCompare) = 0 Then
'... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
Nom_Fichier = Nom_Dossier & "\" & Fichier.Name
Workbooks.OpenText Filename:=Nom_Fichier, DataType:=1, Semicolon:=True, local:=True
End If
Next Fichier
Windows("PiFA.xls").Activate
End Sub
Celui la permet a partir d'un formulaire de choisir ceux qu'il faut trier:
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim TextBox1 As Integer
Workbooks("Profils logistiques.xls").Activate
TextBox1 = Range("H1")
Workbooks("Profils logistiques.xls").Close
Set wb = Workbooks.Open("Y:\Service Expedition\pierre-alexis.bernard\Profils Clients\Profils logistiques.xls")
Set ws = wb.Worksheets("ITEMS saisie manuelle et auto")
ws.Activate
If CheckBox1.Value = True Then
Call Transfert_Carrefour_MDD
End If
If CheckBox2.Value = True Then
Call Transfert_Carrefour_MN
End If
If CheckBox4.Value = True Then
Call Transfert_Scamark_MDD
End If
If CheckBox5.Value = True Then
Call Transfert_Galec_MN
End If
If CheckBox7.Value = True Then
Call Transfert_SuperU_MDD
End If
If CheckBox8.Value = True Then
Call Transfert_SuperU_MN
End If
If CheckBox10.Value = True Then
Call Transfert_Auchan_MDD
End If
If CheckBox11.Value = True Then
Call Transfert_Simply_Atac
End If
If CheckBox12.Value = True Then
Call Transfert_Shiever
End If
If CheckBox14.Value = True Then
Call Transfert_Casino_MN
End If
If CheckBox15.Value = True Then
Call Transfert_Casino_MDD
End If
UserForm5.Hide
Set wb = Workbooks.Open("Y:\Service Commercial\Direction Supply\K- TRANSPORT\2- COUT DE TRANSPORT" & "\" & TextBox1 & "\" & "TCD COUT TPT " & TextBox1 & ".xls")
Set ws = wb.Worksheets("CoûtGlobal")
ws.Activate
'Me garde les valeurs
Dim sht As Worksheet
Dim wkb As Workbook
Set wkb = Workbooks("Profils logistiques")
wkb.Activate
For Each sht In Worksheets
With sht.Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Application.CutCopyMode = False
Next
'enregistre dans un nouveau dossier
Dim NOMDOSSIER$, Chemin$
NOMDOSSIER = Format(Date, "ddmmyyyy") & "_" & Format(Time, "hhmmss")
If Dir(Workbooks("Profils logistiques").Path & "\" & NOMDOSSIER, vbDirectory) = "" Then
MkDir Workbooks("Profils logistiques").Path & "\" & NOMDOSSIER
End If
Chemin = Workbooks("Profils logistiques").Path & "\" & NOMDOSSIER & "\"
Workbooks("Profils logistiques").SaveCopyAs Chemin & "Profils logistiques" & ".xls"
End Sub
et voila un exemple de transfert:
Sub Transfert_Carrefour_MN()
Dim lig As Long
Dim col As String
Dim nbrlig As Long
Dim numlig As Long
Application.Workbooks("Carrefour").Activate
Sheets.Add.Move after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Carrefour_MN"
Sheets("Carrefour_MN").Activate
col = "C"
numlig = 9
With Sheets("Carrefour")
nbrlig = .Cells(65536, col).End(xlUp).Row
For lig = 10 To nbrlig
If .Cells(lig, col).Value = "MARQUES PROPRES" Then
.Cells(lig, col).EntireRow.Copy
numlig = numlig + 1
Cells(numlig, 1).Select
ActiveSheet.Paste
End If
Next
End With
Application.Workbooks("Carrefourexp").Activate
Sheets.Add.Move after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Carrefourexp_MN"
Sheets("Carrefourexp_MN").Activate
col = "C"
numlig = 9
With Sheets("Carrefourexp")
nbrlig = .Cells(65536, col).End(xlUp).Row
For lig = 10 To nbrlig
If .Cells(lig, col).Value = "MARQUES PROPRES" Then
.Cells(lig, col).EntireRow.Copy
numlig = numlig + 1
Cells(numlig, 1).Select
ActiveSheet.Paste
End If
Next
End With
End Sub
' Ouvre tous les fichiers excel contenus dans un répertoire.
'
Dim Système As Object 'Système de fichiers
Dim Dossier As Object 'Répertoire
Dim Fichiers As Object 'Collection de fichiers du répertoire
Dim Fichier As Object 'Fichier (élément de la collection Fichiers)
Dim Nom_Dossier As String 'Nom du répertoire
Dim Nom_Fichier As String 'Nom du fichier
'Lecture du répertoire COMMANDE
Nom_Dossier = "Y:\Service Expedition\pierre-alexis.bernard\Profils Clients\Commande"
Set Système = CreateObject("Scripting.FileSystemObject")
Set Dossier = Système.GetFolder(Nom_Dossier)
Set Fichiers = Dossier.Files
'Contrôler chaque fichier du répertoire
For Each Fichier In Fichiers
'- Vérifier s'il s'agit d'un fichier Excel...
If StrComp(Système.GetExtensionName(Fichier.Name), "csv", vbTextCompare) = 0 Then
'... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
Nom_Fichier = Nom_Dossier & "\" & Fichier.Name
Workbooks.OpenText Filename:=Nom_Fichier, DataType:=1, Semicolon:=True, local:=True
End If
Next Fichier
'Lecture du répertoire EXPEDITION
Nom_Dossier = "Y:\Service Expedition\pierre-alexis.bernard\Profils Clients\Expédition"
Set Système = CreateObject("Scripting.FileSystemObject")
Set Dossier = Système.GetFolder(Nom_Dossier)
Set Fichiers = Dossier.Files
'Contrôler chaque fichier du répertoire
For Each Fichier In Fichiers
'- Vérifier s'il s'agit d'un fichier Excel...
If StrComp(Système.GetExtensionName(Fichier.Name), "csv", vbTextCompare) = 0 Then
'... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
Nom_Fichier = Nom_Dossier & "\" & Fichier.Name
Workbooks.OpenText Filename:=Nom_Fichier, DataType:=1, Semicolon:=True, local:=True
End If
Next Fichier
Windows("PiFA.xls").Activate
End Sub
Celui la permet a partir d'un formulaire de choisir ceux qu'il faut trier:
Private Sub CommandButton1_Click()
Dim wb As Workbook
Dim ws As Worksheet
Dim TextBox1 As Integer
Workbooks("Profils logistiques.xls").Activate
TextBox1 = Range("H1")
Workbooks("Profils logistiques.xls").Close
Set wb = Workbooks.Open("Y:\Service Expedition\pierre-alexis.bernard\Profils Clients\Profils logistiques.xls")
Set ws = wb.Worksheets("ITEMS saisie manuelle et auto")
ws.Activate
If CheckBox1.Value = True Then
Call Transfert_Carrefour_MDD
End If
If CheckBox2.Value = True Then
Call Transfert_Carrefour_MN
End If
If CheckBox4.Value = True Then
Call Transfert_Scamark_MDD
End If
If CheckBox5.Value = True Then
Call Transfert_Galec_MN
End If
If CheckBox7.Value = True Then
Call Transfert_SuperU_MDD
End If
If CheckBox8.Value = True Then
Call Transfert_SuperU_MN
End If
If CheckBox10.Value = True Then
Call Transfert_Auchan_MDD
End If
If CheckBox11.Value = True Then
Call Transfert_Simply_Atac
End If
If CheckBox12.Value = True Then
Call Transfert_Shiever
End If
If CheckBox14.Value = True Then
Call Transfert_Casino_MN
End If
If CheckBox15.Value = True Then
Call Transfert_Casino_MDD
End If
UserForm5.Hide
Set wb = Workbooks.Open("Y:\Service Commercial\Direction Supply\K- TRANSPORT\2- COUT DE TRANSPORT" & "\" & TextBox1 & "\" & "TCD COUT TPT " & TextBox1 & ".xls")
Set ws = wb.Worksheets("CoûtGlobal")
ws.Activate
'Me garde les valeurs
Dim sht As Worksheet
Dim wkb As Workbook
Set wkb = Workbooks("Profils logistiques")
wkb.Activate
For Each sht In Worksheets
With sht.Cells
.Copy
.PasteSpecial Paste:=xlPasteValues
.PasteSpecial Paste:=xlPasteFormats
End With
Application.CutCopyMode = False
Next
'enregistre dans un nouveau dossier
Dim NOMDOSSIER$, Chemin$
NOMDOSSIER = Format(Date, "ddmmyyyy") & "_" & Format(Time, "hhmmss")
If Dir(Workbooks("Profils logistiques").Path & "\" & NOMDOSSIER, vbDirectory) = "" Then
MkDir Workbooks("Profils logistiques").Path & "\" & NOMDOSSIER
End If
Chemin = Workbooks("Profils logistiques").Path & "\" & NOMDOSSIER & "\"
Workbooks("Profils logistiques").SaveCopyAs Chemin & "Profils logistiques" & ".xls"
End Sub
et voila un exemple de transfert:
Sub Transfert_Carrefour_MN()
Dim lig As Long
Dim col As String
Dim nbrlig As Long
Dim numlig As Long
Application.Workbooks("Carrefour").Activate
Sheets.Add.Move after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Carrefour_MN"
Sheets("Carrefour_MN").Activate
col = "C"
numlig = 9
With Sheets("Carrefour")
nbrlig = .Cells(65536, col).End(xlUp).Row
For lig = 10 To nbrlig
If .Cells(lig, col).Value = "MARQUES PROPRES" Then
.Cells(lig, col).EntireRow.Copy
numlig = numlig + 1
Cells(numlig, 1).Select
ActiveSheet.Paste
End If
Next
End With
Application.Workbooks("Carrefourexp").Activate
Sheets.Add.Move after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = "Carrefourexp_MN"
Sheets("Carrefourexp_MN").Activate
col = "C"
numlig = 9
With Sheets("Carrefourexp")
nbrlig = .Cells(65536, col).End(xlUp).Row
For lig = 10 To nbrlig
If .Cells(lig, col).Value = "MARQUES PROPRES" Then
.Cells(lig, col).EntireRow.Copy
numlig = numlig + 1
Cells(numlig, 1).Select
ActiveSheet.Paste
End If
Next
End With
End Sub
rasoa10
Messages postés
831
Date d'inscription
mardi 20 mai 2008
Statut
Membre
Dernière intervention
8 février 2021
271
18 juil. 2013 à 16:29
18 juil. 2013 à 16:29
Bonjour,
Si tu mets ton problème en résolu, personne ne va te répondre, attention !
Si tu mets ton problème en résolu, personne ne va te répondre, attention !
biboupifa
Messages postés
54
Date d'inscription
mardi 11 juin 2013
Statut
Membre
Dernière intervention
19 juillet 2013
18 juil. 2013 à 16:41
18 juil. 2013 à 16:41
Bonjour,
oui en effet j'en suis bien conscient. si tu as la solution je veux bien. mais en fait en creusant le problème j'ai fini par comprendre la source du problème, que je ne sais toujours pas résoudre. mais plutot que de faire lire a quelqu'un ce pavé pour une raison qui correspond a une ligne j'ai préféré créer un nouveau post que voila:
https://forums.commentcamarche.net/forum/affich-28281493-mon-csv-ne-reconnait-pas-mon-texte#p28281493
merci en tout cas :)
oui en effet j'en suis bien conscient. si tu as la solution je veux bien. mais en fait en creusant le problème j'ai fini par comprendre la source du problème, que je ne sais toujours pas résoudre. mais plutot que de faire lire a quelqu'un ce pavé pour une raison qui correspond a une ligne j'ai préféré créer un nouveau post que voila:
https://forums.commentcamarche.net/forum/affich-28281493-mon-csv-ne-reconnait-pas-mon-texte#p28281493
merci en tout cas :)
biboupifa
Messages postés
54
Date d'inscription
mardi 11 juin 2013
Statut
Membre
Dernière intervention
19 juillet 2013
18 juil. 2013 à 16:44
18 juil. 2013 à 16:44
dans le doute, si je me trompe je le remets en non résolu :)
18 juil. 2013 à 12:56