XL 2019 Si cellule contient un mot alors copier la valeur d'une autre cellule - Macro (VBA)

[Jackdu95]

Bonjour,

J'aimerais par un macro en vba dans le fichier "macros.xlsm", feuille xxx copier les donnees des fichiers "donnees.xlsx" et "donnees2.xlsx" de la maniere suivante:

donnees.xlsx

- si on trouve dans la colonne A entiere le texte "qwerty" alors prendre le resultat "100" de la cellule C1 et le copier dans la feuille xxx du classeur macros.xlsm
je voudrais avoir le texte "qwerty"en A1 et "100" en B1
- si on trouve dans la colonne B entiere le texte "entrees:" alors prendre le resultat "240" de la cellule D2 et le copier dans la feuille xxx du classeur macros.xlsm
je voudrais avoir le texte "entrees:"en A2 et "240" en B2
etc....
si on trouve 2 "qwerty" dans la meme colonne alors copier les deux resultats l'un en dessous de l'autre avec le meme texte.
nb. les resultat appartiennent au texte de la meme ligne.

donnees2.xlsx

meme chose a la suite.

Vous avez la reponse que je voudrais obtenir dans le classeur "macros.xlsm"

nb. imaginons que les deux fichiers sont remplis de texte en double ou triple...

EDIT: pour simplifier les choses au lieu de choisir une seule colonne on pourrait choisir par exemple dans donnees.xlsx la colonne A et B en meme temps pour chercher un texte. idem pour donnees2.xlsx

Merci par avance

Jack

 

[job75]

Bonsoir Jackdu95,

La question est un peu tarabiscotée mais bon téléchargez les fichiers joints dans le même dossier (le bureau) et exécutez cette macro :

Sub MAJ()
Dim chemin$, fichier, F As Worksheet, ligne&, lig&, col%, fich, P As Range, ncol%, i&, j%, k%
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Array("donnees.xlsx", "donnees2.xlsx") 'liste à adapter
Set F = Feuil1 'CodeName, à adapter
ligne = 1 '1ère ligne de destination, à adapter
lig = ligne
col = 1 '1ère colonne de destination, à adapter
Application.ScreenUpdating = False
F.Cells(ligne, col).Resize(F.Rows.Count - ligne + 1, 2).ClearContents 'RAZ
For Each fich In fichier
    If Dir(chemin & fich) = "" Then
        MsgBox "Fichier " & fich & " introuvable !", 48
    Else
        Workbooks.Open chemin & fich
        Set P = ActiveSheet.UsedRange
        ncol = P.Columns.Count
        For i = 1 To P.Rows.Count
            For j = 1 To ncol
                If TypeName(P(i, j).Value) = "String" Then
                    For k = j + 1 To ncol
                        If IsNumeric(CStr(P(i, k))) Then
                            F.Cells(lig, col) = P(i, j)
                            F.Cells(lig, col + 1) = P(i, k)
                            lig = lig + 1
                            Exit For
                        End If
                    Next k
                End If
        Next j, i
        ActiveWorkbook.Close False
    End If
Next fich
If lig > ligne Then F.Cells(ligne, col).Resize(lig - ligne, 2).Sort F.Cells(ligne, col), xlAscending, Header:=xlNo 'tri
End Sub

Dans les fichiers sources il doit y avoir des nombres à droite des textes.

A+