Ouvrir un fichier avec GetOpenFilename
Bonjour à tous,
Suis-je devenu fou, ou bien avant de le devenir... je lance une bouteille à la mer...
Je vous explique mon code, en fait, j'ai un fichier de base (ActiveW), qui va ouvrir un fichier source (WorkBookOpen).
En fait WorkBookOpen c'est un tableau que je coupe en 4 au niveau des lignes pour en créer quatres tables dans 4 onglets.
Ensuite c'est 4 tables nommées feront de jolis graphiques...
Et là, le code est lu normalement jusqu'à "For i = 5 To nblignes " c'est un autre onglet qui est lu...
L'information à lire est sur l"onglet realprod qui appartient à WorkBookOpen et je veux les copier sur ActiveW et un des 4 onglets.
Pouvez-vous m'aider ??
Public Sub AjouterFichierCausePerteDeTemps()
Dim ActiveW As Workbook
Set ActiveW = ActiveWorkbook
Dim onglet As Integer
Dim idebut As Integer
Dim ifin As Integer
Dim nbcaractere As Integer
Dim chaineAEtudier As String
Dim NomOnglet As String
Dim y As Integer
'La variable est de type Variant car elle peut prendre les valeurs:
'Booleenne: (Vrai/Faux) quand l'utilisateur ne sélectionne rien, ou annule l'opération.
'String: pour renvoyer le nom du fichier sélectionné.
Dim Fichier As Variant
'Affiche la boîte de dialogue "Ouvrir"
Fichier = Application.GetOpenFilename("Tous les fichiers (*.xls),*.*")
'On sort si aucun fichier n'a été sélectionné ou si l'utilisateur
'a cliqué sur le bouton "Annuler", ou sur la croix de fermeture.
If Fichier = False Then Exit Sub
'Affiche le chemin et le nom du fichier sélectionné.
'MsgBox Fichier
Dim WorkBookOpen As Workbook
Set WorkBookOpen = Workbooks.Open(Filename:=Fichier)
WorkBookOpen.Activate
MsgBox "k"
Sheets("realprod").Select
'je verifie le nombre de ligne qu il y a dans la fichierRealProd
Dim i As Integer
i = 5 ' premiere ligne du fichier brut
MsgBox "r"
'Cells(i, 1).Select
Do While Cells(i, 1).Value <> ""
'MsgBox Cells(i, 4).Value
i = i + 1
Loop
i = i + 1
MsgBox "nombre de ligne :" & i
Dim nblignes As Integer
nblignes = i
' i = nombre de ligne dans le tableau
' j enleve a i lentete et la ligne vide au dessus
i = i - 4
'Nous allons determiner l onglet dans lequel mettre linformation en fonction de la place de la ligne dans le tablea
onglet = 1
WorkBookOpen.Activate
'WorkBookOpen.Select
Sheets("realprod").Select
For i = 5 To nblignes
'essaie de determiner dans quel onglet j ecris l information
y = i
Do While InStr(WorkBookOpen.Cells(y, 1).Value, "Total") = False
MsgBox WorkBookOpen.Cells(y, 2).Value
idebut = y
y = y + 1
Loop
ifin = y
chaineAEtudier = Cells(i, 1).Value
MsgBox Len(chaineAEtudier)
nbcaractere = Len(Cells(i, 1).Value)
NomOnglet = Mid(chaineAEtudier, 6, nbcaractere) ' exclu la valeur total qui a apparati pas dans les titres des onglets
MsgBox NomOnglet
Select Case NomOnglet
Case "Activité 1"
onglet = 1
Case "Activite 2"
onglet = 2
Case "G.I.U."
onglet = 3
Case "Externe"
onglet = 4
End Select
ActiveW.Activate
Dim z As Integer
For z = 1 To 6 ' colonne a copier a chaque fois
Sheets(onglet).Select
WorkBookOpen.Activate
Cells(i, z).Select
Selection.Copy
ActiveW.Activate
Cells(i, z).Paste
Next
Next
WorkBookOpen.Close
End Sub
Merci d'avance pour vos réponses,
Bonjour,
Question:
pour la feuille "realprod"
- les données commence à la ligne, et la colonne ?
- la colonne A est la colonne qui a le plus de données ?
les feuilles "Activité 1", "Activite 2", "G.I.U.", "Externe" sont t'elle vide ?
sinon quel sont les colonnes déjà renseignées ?
re,
à tester,
Sub test()
Dim WorkBookOpen As Workbook, wk1 As Workbook, onglet, plg
Dim deb As Long, n As Integer, ligne As String, i As Integer
Set wk1 = ThisWorkbook
onglet = Array("", "Activité 1", "Activite 2", "G.I.U.", "Externe")
Application.ScreenUpdating = False
'-----lire le fichier onglet "realprod"-------------------------------
Fichier = Application.GetOpenFilename(FileFilter:="Tous les fichiers (*.xls),*.*", MultiSelect:=False)
If Fichier = False Then Application.ScreenUpdating = True: Exit Sub
Set WorkBookOpen = Workbooks.Open(Filename:=Fichier)
Sheets("realprod").Copy After:=wk1.Sheets(Sheets.Count)
WorkBookOpen.Close SaveChanges:=False ' fermer le classeur et ignorer toutes les modifications qui lui ont été apportées.
'-----transfert les lignes---------------------------------------------
Lastrow = Sheets("realprod").Cells(Rows.Count, 1).End(xlUp).Row
n = Int(Lastrow / 4)
deb = 2
For i = 1 To 4
rw = Sheets(onglet(i)).Cells(Rows.Count, 1).End(xlUp).Row + 1
ligne = deb & ":" & deb + n - 1
plg = Sheets("realprod").Rows(ligne)
Sheets(onglet(i)).Range("A" & rw).Resize(UBound(plg), Columns.Count) = plg
deb = deb + n
Next
Application.DisplayAlerts = False
Sheets("realprod").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Bonjour,
Merci beaucoup pour ce travail, je n'ai pas le temps de le tester aujourd'hui, je reviens vers vous très rapidement.