Visual Basic, VB6, VB.NET, VB 2005, VB CodeS-SourceS

CodeS-SourceS est hébergé par Frontier.fr

Ce site au démarrage

begin process at 2013 05 23 22:13:14

Accueil Codes Tutoriels Forum Livres Emploi Services Connexion

Trouver un code source :

dans

[ Dernières recherches ]

Accueil > Forum >

Traitement de données entre diffrents tableau

Poser une question dans le forum ou lancer une discussion

Traitement de données entre diffrents tableau

mardi 28 août 2012 à 14:29:31 | Traitement de données entre diffrents tableau

azertym

42 msg

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 :

Code Visual Basic :

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.

mardi 28 août 2012 à 18:01:38 | Re : Traitement de données entre diffrents tableau

jack

13260 msg

13344 msg CS

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)

mercredi 29 août 2012 à 08:54:10 | Re : Traitement de données entre diffrents tableau

azertym

42 msg

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

mercredi 29 août 2012 à 14:01:17 | Re : Traitement de données entre diffrents tableau

azertym

42 msg

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"

Code Visual Basic :

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.

Cette discussion est classée dans : macro, source, destination, range, classeurentree

Répondre à ce message

Sujets en rapport avec ce message

Macro excel qui plante "Méthode Range" [ par Pangs ] J'ai un probleme avec une macro ecxel .Cette macro execute un graphique 3d de surface, et sa premiere ligne de code est : Range("B2:AG23").Select . Copie de disque [ par christobal ] Bonjour a vous,j'expose mon cas. Dans mon apli j'ai deux selections de disque (un pour la source un pour la destination).L'orsque je cliquerais sur le selection de cellule ds excel [ par klyn ] Je voudrais faire une macro pour selectionner les lignes d'une feuille excel a condition que la colonne I soit egale a "MOS9". J'ai fait une macro mai Prob Drag'n Drop [ par RamBoF ] Voila j'aimerais copier plusieurs fichiers en meme temps d'une destination source à une destination cible par l'intermédaire d'un Drag'n drop entre 2 Progress Bar (krn) [ par kataragon ] J'aimerai insérer une barre de progression dans le code ci-dessous pour voir l'avancement de la copie des fichiers.Merci kataragonPrivate Sub OUI_Cli Range .... J'ARRIVE PAS !!!!!! [ par flag2000 ] Salut, je voudrais écrire une macro vba dans excel qui m'étende vers le haut de feuille n'importe quelle zone d'impression définie. Ex : si ma zone d' pb macro excel [ par patou06 ] bonsoirDans le vif du sujet je souhaite1 que ma macro fonctionne (logique) voici le code:Sub autoexec() 'calcul du numéro de la premiere ligne vide probleme de liaison [ par maurpheuss54 ] bonjours tout le monde ,voila, j'ai cree sur un reseau 2 fichiers excel que je vais appeler source.xls et recap.xls pour que se soit plus simple !le Problème Macro Excel [ par vsan ] Bonjour à tous ! Je m’adresse à vous afin de solutionner un problème que je rencontre avec Excel et les macros VB help macro excel [ par patou06 ] bonsoirDans le vif du sujet je souhaite1 que ma macro fonctionne (logique) voici le code:Sub autoexec() 'calcul du numéro de la premiere ligne vide

Livres en rapport

Open Source Development with CVS

Macromedia freehand 10 training from the source

Services Web Open Source

A programmer's guide to sound

Tous les livres pour Macro, Source, Destination, Range, Classeurentree

Nos sponsors

Derniers Blogs

SIMULER FACILEMENT L'ENVOI DE MAIL par JeremyJeanson

PROCDUMP 6.0 : SUPPORT DU FILTRAGE SUR MESSAGES D'EXCEPTIONS .NET, DES FILTRES MULTIPLES ET DU CIBLAGE PAR NOM DE SERVICE par coq

VOTEZ POUR LE TOP 10 DES INFLUENCEURS SHAREPOINT FRANCOPHONES ! par Patrick Guimonet

[CONF'SHAREPOINT] DERNIER RAPPEL ! :-) par Patrick Guimonet

[ #SHAREPOINT 2013 ] LES MODèLES DE SITES STANDARDS. par Patrick Guimonet

Forum

RE : RECHERCHER UN FICHIER SUR SON ORDINATEUR DEPUIS UN LOGICIEL par ucfoutu

RE : RECHERCHER UN FICHIER SUR SON ORDINATEUR DEPUIS UN LOGICIEL par acive

RE : EXERCICE SUR VB6 par ShayW

RE : ENCORE WMP - AUCUNE LOGIQUE LA DEDANS... par banana32

Côté IT

Offres d'emploi

Formations Video

Appels d'offres

Animation Travaux diriges UML pour etudiants en 1ere annee Institut G4
Budget : 600€
Reconfiguration site Open-Realty
Budget : 800€
concevoir une page en ligne ayant une base de donnees
Budget : 800€

Logiciels

Easy-Planning (4.5.0.11)
EASY-PLANNING (4.5.0.11)

Easy-Planning permet de créer des plannings sous la représentation de diagrammes et est adapté a...

Cliquez pour télécharger Easy-Planning
CVEasy (3.1.0.51)
CVEASY (3.1.0.51)

PHMSD-CVEasy est un logiciel d'aide à la rédaction de CV d'une simplicité déconcertante. PHMSD-C...

Cliquez pour télécharger CVEasy
LettresFaciles 2011 (8.6.0.31)
LETTRESFACILES 2011 (8.6.0.31)

LettresFaciles est un logiciel facilitant la création et la rédaction de lettres types. Son inte...

Cliquez pour télécharger LettresFaciles 2011
sDEVIS-FACTURES vlPRO (8.4.2.62)
SDEVIS-FACTURES VLPRO (8.4.2.62)

sDEVIS-FACTURES vlPRO a été mis au point pour les particuliers, créateurs, entrepreneurs, artisa...

Cliquez pour télécharger sDEVIS-FACTURES vlPRO
Devis-Factures PHMSD (2.1.0.11)
DEVIS-FACTURES PHMSD (2.1.0.11)

Configuration minimale Nécessite Windows™ 2000, XP, Windows 7, 8, Vista (Service Pack à...

Cliquez pour télécharger Devis-Factures PHMSD