Sujet Précédent Sujet Suivant

Traitement de données entre diffrents tableau

azertym Messages postés 47 Date d'inscription vendredi 8 août 2003 Statut Membre Dernière intervention 7 décembre 2014 - 28 août 2012 à 14:29
azertym Messages postés 47 Date d'inscription vendredi 8 août 2003 Statut Membre Dernière intervention 7 décembre 2014 - 29 août 2012 à 14:01
Bonjour à tous,

J'utilise une macro qui a été programmée par une autre personne. Cependant cette macro ne fonctionne pas correctement.

La macro fonctionne ainsi :
1 classeur Excel qui va rechercher 2 autres classeurs via un bouton "parcourir".
Les 2 autres classeurs possèdent exactement les mêmes onglets.

L'import des classeurs se fait correctement mais j'aimerai optimiser la macro.

En effet, je souhaiterai faire en sorte que, si tel chiffre est dans telle colonne de la feuille 5 du classeur 2 alors copier dans la cellule de la feuille "5" du classeur 1.

J'utilise ce code ci : 
Sub CopyCutOffs(classeurEntree As Workbook)
    ' 532
    Call CopyCutOff(classeurEntree, "Laser1", "A")
    ' 638
    Call CopyCutOff(classeurEntree, "Laser2", "B")
    ' 785
    Call CopyCutOff(classeurEntree, "Laser3", "C")
End Sub

Sub CopyCutOff(classeurEntree As Workbook, laser As String, destinationColumn As String)
    Dim rowNumber As Range
    Dim source As Worksheet, destination As Worksheet
    
    Set source = classeurEntree.Worksheets("Cut_Off")
    Set destination = classeurSortie.Worksheets("Cut_Off")

    ' Numero de ligne du lambda correspondant
    Set rowNumber = source.Range("B:B").Cells.Find(What:=laser)

    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("C" & rowNumber.Row).Value
    
    ' Import date
    destination.Range("D" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = Now
    ' Source file
    destination.Range("E" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = classeurEntree.Path & "" & classeurEntree.Name
End Sub


j'aimerai aussi qu'une fois l'opération terminée, la macro détecte la derniere ligne vide pour importer le prochain fichier par la suite.

Je ne sais pas si je suis très claire, sinon n'hésitez pas.

3 réponses

Réponse 1 / 3
cs_Jack Messages postés 14006 Date d'inscription samedi 29 décembre 2001 Statut Modérateur Dernière intervention 28 août 2015 79
28 août 2012 à 18:01
Salut

Ça, c'est ce que tu aimerais faire, mais qu'as-tu commencé à faire ?
Sur quel problème bloques-tu ?

Vala
Jack, MVP VB
NB : Je ne répondrai pas aux messages privés

Le savoir est la seule matière qui s'accroit quand on la partage (Socrate)
0
Réponse 2 / 3
azertym Messages postés 47 Date d'inscription vendredi 8 août 2003 Statut Membre Dernière intervention 7 décembre 2014
29 août 2012 à 08:54
Salut Jack,

Je vais tout ré-expliquer, je suis reparti sur une autre piste, je reprends tout de zero.

En fait, le but c'est d'ouvrir un classeur (1). Ce classeur a l'ouverture va demander d'aller chercher le dossier qui contient plusieurs autres classeurs excel.
Une fois les classeurs importer. Certaines données de ces classeurs (à chaque fois au même endroit dans les classeurs) vont-être importés dans un onglet du classeur 1.

Pour le moment j'ai donc créer mon classeur 1 avec a l'ouverture un Userform demandant d'aller chercher le dossier qui contient les différents classeurs.
Dans un textbox le chemin de ce dossier est affiché. La ou je bloque c'est que je n'arrive pas a afficher les classeurs qui on été importé dans le deuxième textbox. Et je n'arrive pas aussi a copier les valeurs de ces différents classeurs dans le classeur 1.

Voici mon classeur 1
http://www54.zippyshare.com/v/2841527/file.html
0
Réponse 3 / 3
azertym Messages postés 47 Date d'inscription vendredi 8 août 2003 Statut Membre Dernière intervention 7 décembre 2014
29 août 2012 à 14:01
Bon et bien voilà, j'avance un peu.
j'ai modifié quelques trucs dans la macro initial. Cependant je rencontre un problème lors de l'opération "cut_off","CopyConfocalite", "CopyResolutionAxiale", "CopyPuissanceéchantillons" 
Dim classeurSortie As Workbook
Dim importFolder

Sub ImporterDonnees()
    Set classeurSortie = ActiveWorkbook
    importFolder = classeurSortie.Worksheets("Home").Range("D17").Value
    Dim result As Long
    result = MsgBox("Importer les donnees depuis '" & importFolder & "' ?", vbYesNo, "Confirmation import")
    ' Clic sur Oui
    If (result = 6) Then
        Call ImportData
    End If
End Sub

Sub ImportData()
  Dim objFSO, objDossier, objFichier, objResultat
  Dim classeurEntree As Workbook
  Dim txtMsg As String

  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objDossier = objFSO.GetFolder(importFolder)

  txtMsg = "Fichiers importes:" & Chr(10)

  ' Desactivation du rafraichissement (gain de performances)
  Application.ScreenUpdating = False

  If (objDossier.Files.Count > 0) Then
     For Each objFichier In objDossier.Files
        If (InStr(1, objFichier.Name, ".xls", 1) > 0) Then
            Set classeurEntree = Workbooks.Open(objFichier.Path)
            Call ImporterClasseur(classeurEntree)
            
            txtMsg = txtMsg & " - " & objFichier.Name & Chr(10)
        End If
     Next
   Else
    txtMsg = txtMsg & "Aucun"
   End If

    ' Reactivation du rafraichissement
    Application.ScreenUpdating = True

    ' Selection du 1er onglet
    classeurSortie.Worksheets("Home").Activate

    MsgBox txtMsg, vbInformation, "Import termine"
End Sub

Sub ImporterClasseur(classeurEntree As Workbook)
    ' LinReseauX
    Call CopyLinReseauX(classeurEntree, 1)
    Call CopyLinReseauX(classeurEntree, 2)
    Call CopyLinReseauX(classeurEntree, 3)
    Call CopyLinReseauX(classeurEntree, 4)

    ' Cut-off
    Call CopyCutOffs(classeurEntree)

    ' Exactitude
    Call CopyExactitudes(classeurEntree)

    ' Resolution Axiale
    Call CopyResolutionAxiales(classeurEntree)
    
    ' Confocalite
    Call CopyConfocalites(classeurEntree)
    
    ' Puissance échantillon
    Call CopyPuissanceéchantillon(classeurEntree)
    
    ' Ecriture du log
    Set destination = classeurSortie.Worksheets("Home")
    Dim rowNumber
    rowNumber = destination.Range("C" & destination.Rows.Count).End(xlUp).Row + 1
    destination.Range("C" & rowNumber) = Now
    destination.Range("D" & rowNumber) = classeurEntree.Path & "" & classeurEntree.Name

    classeurEntree.Close
End Sub

Sub CopyLinReseauX(classeurEntree As Workbook, i As Integer)
    Dim source As Worksheet, destination As Worksheet
    Set source = classeurEntree.Worksheets("LinReseau" & i)
    Set destination = classeurSortie.Worksheets("LinReseau" & i)

    Dim beginSrc, beginDest, nbRows
    beginSrc = 8
    beginDest = destination.Range("B" & source.Rows.Count).End(xlUp).Row + 1
    nbRows = source.Range("D" & source.Rows.Count).End(xlUp).Row - beginSrc

    Dim j As Integer
    For j = 0 To nbRows
        ' (nm)
        destination.Range("B" & beginDest + j) = source.Range("D" & beginSrc + j)
        ' (cm-1)
        destination.Range("C" & beginDest + j) = source.Range("E" & beginSrc + j)
        ' Import date
        destination.Range("D" & beginDest + j) = Now
        ' Source file
        destination.Range("E" & beginDest + j) = classeurEntree.Path & "" & classeurEntree.Name
    Next j
End Sub

Sub CopyCutOffs(classeurEntree As Workbook)
    ' 532
    Call CopyCutOff(classeurEntree, "Laser1", "A")
    ' 638
    Call CopyCutOff(classeurEntree, "Laser2", "B")
    ' 785
    Call CopyCutOff(classeurEntree, "Laser3", "C")
End Sub

Sub CopyCutOff(classeurEntree As Workbook, laser As String, destinationColumn As String)
    Dim rowNumber As Range
    Dim source As Worksheet, destination As Worksheet

    Set source = classeurEntree.Worksheets("Cut_Off")
    Set destination = classeurSortie.Worksheets("Cut_Off")

    ' Numero de ligne du lambda correspondant
    Set rowNumber = source.Range("B:B").Cells.Find(What:=laser)

    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("C" & rowNumber.Row).Value
    
    ' Import date
    destination.Range("D" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = Now
    ' Source file
    destination.Range("E" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = classeurEntree.Path & "" & classeurEntree.Name
End Sub
Sub CopyResolutionAxiale(classeurEntree As Workbook, laser As String, destinationColumn As String)
    Dim rowNumber As Range
    Dim source As Worksheet, destination As Worksheet

    Set source = classeurEntree.Worksheets("Confocalite")
    Set destination = classeurSortie.Worksheets("Resolution_Axiale")

    ' Numero de ligne du lambda correspondant
    Set rowNumber = source.Range("B:B").Cells.Find(What:=laser)

    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("E" & rowNumber.Row + 5).Value
    
    ' Import date
    destination.Range("D" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = Now
    ' Source file
    destination.Range("E" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = classeurEntree.Path & "" & classeurEntree.Name
End Sub
Sub CopyConfocalite(classeurEntree As Workbook, laser As String, destinationColumn As String)
    Dim rowNumber As Range
    Dim source As Worksheet, destination As Worksheet

    Set source = classeurEntree.Worksheets("Confocalite")
    Set destination = classeurSortie.Worksheets("confocalite")

    ' Numero de ligne du lambda correspondant
    Set rowNumber = source.Range("B:B").Cells.Find(What:=laser)

    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("E" & rowNumber.Row + 3).Value
    
    ' Import date
    destination.Range("D" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = Now
    ' Source file
    destination.Range("E" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = classeurEntree.Path & "" & classeurEntree.Name
End Sub
Sub CopyExactitudes(classeurEntree As Workbook)
    ' 600T
    Call CopyExactitude(classeurEntree, "A", "I28")
    ' 1200T
    Call CopyExactitude(classeurEntree, "B", "I48")
    ' 1800T
    Call CopyExactitude(classeurEntree, "C", "I68")
    ' 2400T
    Call CopyExactitude(classeurEntree, "D", "I88")
End Sub

Sub CopyExactitude(classeurEntree As Workbook, destinationColumn As String, srcRange As String)
    Dim source As Worksheet, destination As Worksheet
    Set source = classeurEntree.Worksheets("Exactitude")
    Set destination = classeurSortie.Worksheets("Exactitude")

    destination.Range(destinationColumn & destination.Range(destinationColumn & destination.Rows.Count).End(xlUp).Row + 1) = source.Range(srcRange).Value
    
    ' Import date
    destination.Range("E" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = Now
    ' Source file
    destination.Range("F" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = classeurEntree.Path & "" & classeurEntree.Name
End Sub
Sub CopyPuissanceéchantillons(classeurEntree As Workbook, laser As String, destinationColumn As String)
    Dim rowNumber As Range
    Dim source As Worksheet, destination As Worksheet

    Set source = classeurEntree.Worksheets("data_objectifs")
    Set destination = classeurSortie.Worksheets("Puissance échantillon")

    ' Numero de ligne du lambda correspondant
    Set rowNumber = source.Range("I:I").Cells.Find(What:=laser)

    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("I" & rowNumber.Row + 12).Value
    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("I" & rowNumber.Row + 17).Value
    destination.Range(destinationColumn & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row + 1) = source.Range("I" & rowNumber.Row + 22).Value
    ' Import date
    destination.Range("D" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = Now
    ' Source file
    destination.Range("E" & destination.Range(destinationColumn & source.Rows.Count).End(xlUp).Row) = classeurEntree.Path & "" & classeurEntree.Name
End Sub

Sub CopyResolutionAxiales(classeurEntree As Workbook)
    '785
    Call CopyResolutionAxiale(classeurEntree, "Laser1", "C")
    ' 638
    Call CopyResolutionAxiale(classeurEntree, "Laser2", "B")
    ' 532
    Call CopyResolutionAxiale(classeurEntree, "Laser3", "A")
End Sub
Sub CopyConfocalites(classeurEntree As Workbook)
    ' 785
    Call CopyConfocalite(classeurEntree, "Laser1", "C")
    ' 638
    Call CopyConfocalite(classeurEntree, "Laser2", "B")
    ' 532
    Call CopyConfocalite(classeurEntree, "Laser3", "A")
End Sub
Sub CopyPuissanceéchantillon(classeurEntree As Workbook)

    ' 785
    Call CopyPuissanceéchantillons(classeurEntree, "Laser1", "C")
    ' 638
    Call CopyPuissanceéchantillons(classeurEntree, "Laser2", "B")
    ' 532
    Call CopyPuissanceéchantillons(classeurEntree, "Laser3", "A")
    End Sub


La copie de ces différents éléments s'effectue sans encombre, sauf pour la date et la source. Il me copie la date et la source dans l'entête du tableau (en ligne 1 et non en ligne 2). Je n'arrive pas a comprendre pourquoi.
0

Discussions similaires

Turbo C++
cs_jrod -
cmarsc -

1 réponse
Etablir toutes les combinaisons possibles du Lotto
KBNchapal -
Mikaels35 -

6 réponses
TURBO C++ et blocks que choisir
norman bates -
Vale Erian -

1 réponse
Erreur de conversion du type de données varchar en numeric.
cs_houba80 -
SharpMao -

3 réponses
Prob de Restauration base de données
cindyb -
Orange -

3 réponses
Rejoignez-nous