VB Résolu/Fermé

Question

Bonjour,
j'ai besoin d'aide afin de pouvoir remplir une feuille excel automatiquement à partir d'une autre feuille excel du meme classeur qui contient des valeurs.

le probléme qui me bloc est le suivant :

Dans la premiere feuille j'ai des comptes (exemple 1111) dans la premiere colonne et des valeurs dans la deuxième.

dans les autres feuilles , je n'ai que des sous comptes (exemple 111) 

je veu faire appel aux valeurs de la premiere feuille vers les autres feuilles et je veu que VB reconnait le compte et déplace la valeur.

exemple : 

feuille 1 contient les comptes suivants : 1111, 1119, 1117, 1112 devant lesquelles il y a des valeurs
feuille 2 contient le sous compte suivant : 111

je veu une fonction qui peut reconnaitre les comptes qui contiennent le sous compte 111 et les mettre sur la feuille 2 avec leurs valeurs. 

si vous pouvez m'aider, merci d'avance.

jjsteing · Answer

Bonjour :)
Vouci le code demander à mettre en macro ou , comme ici (http://dl.free.fr/getfile.pl?file=/kF0ItT4B dans un bouton de commande..

Private Sub CommandButton1_Click()
Dim CelleulePrincipale As String
Dim Cellule2 As String
Dim i As Integer, j As Integer, Dercelli As Integer, Dercellj As Integer
Dim LigneEnCours As Integer
a = Worksheets("Feuil2").Range("A1").End(xlDown).Address
Dercelli = Right(a, Len(a) - InStr(2, a, "$"))
LigneEnCour = 1

For i = 1 To Dercelli + 1
i = LigneEnCour
CelleulePrincipale = Worksheets("Feuil2").Cells(i, 1)
a = Worksheets("Feuil1").Range("A1").End(xlDown).Address
Dercellj = Right(a, Len(a) - InStr(2, a, "$"))
For j = 1 To Dercellj
    Cellule2 = Worksheets("Feuil1").Cells(j, 1)
    If CelleulePrincipale = Left(Cellule2, Len(CelleulePrincipale)) And _
        Cellule2 <> CelleulePrincipale Then
        Worksheets("Feuil2").Rows(LigneEnCour + 1).Insert Shift:=xlDown
        Worksheets("Feuil2").Cells(LigneEnCour + 1, 1) = Worksheets("Feuil1").Cells(j, 1)
        Worksheets("Feuil2").Cells(LigneEnCour + 1, 2) = Worksheets("Feuil1").Cells(j, 2)
        LigneEnCour = LigneEnCour + 1
    End If
Next
a = Worksheets("Feuil2").Range("A1").End(xlDown).Address
Dercelli = Right(a, Len(a) - InStr(2, a, "$"))
LigneEnCour = LigneEnCour + 1
Next
End Sub

VB

1 réponse

Discussions similaires