Répartir colonne A sur colonne B

Bonjour à tous,

Je suis tout à fait novice sur Excel et j'aurai besoin de votre aide pour le fichier présent dans le lien ci dessous.

Sauriez vous m'aider à répartir mes clients sur mes hiérarchies, je m'explique j'ai besoin que chaque client soit présent devant chaque hiérarchie. Par exemple :

Client A

Hiérarchie : 1, 2, 3 ,4.

Le résultat devra donc étre A - 1 / A- 2 / A-3 et ainsi de suite.

J'ai 842 clients et 198 hiérarchies. le fichier devra au total comporter 166716 lignes ( 842 * 198).

Colonne A = clients

Colonne B = hiérarchies.

Sur la feuille 3 du fichier il y a un exemple

Un grand merci pour votre aide précieuse.

Salut Manu et

à tester

Sub RepartirColonne()

Dim shtCl As Worksheet, shtHi As Worksheet, shtRe As Worksheet
Dim DerLigneCl As Long, DerLigneHi As Long, DerLigneRe As Long
Dim i, j

Application.ScreenUpdating = False

With ThisWorkbook
    .Sheets.Add(After:=.Sheets(.Sheets.Count)).Name = "resultat"
End With

Set shtCl = Sheets("Liste Client")
Set shtHi = Sheets("Hiérarchie")
Set shtRe = Sheets("resultat")

DerLigneCl = shtCl.Cells(shtCl.Rows.Count, "A").End(xlUp).Row
DerLigneHi = shtHi.Cells(shtHi.Rows.Count, "A").End(xlUp).Row

shtRe.Range("A1") = shtCl.Range("A1")
shtRe.Range("B1") = shtHi.Range("A1")

For i = 2 To DerLigneCl
DerLigneRe = shtRe.Cells(shtRe.Rows.Count, "A").End(xlUp).Row - 1
    For j = 2 To DerLigneHi
    shtRe.Range("A" & j + DerLigneRe) = shtCl.Range("A" & i)
    shtRe.Range("B" & j + DerLigneRe) = shtHi.Range("A" & j)
    Next j
Next i

Application.ScreenUpdating = True
End Sub

@++

Salut Manu,

Salut m3ellem1,

un double-clic en 'Liste clients' [A1] démarre la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tTab1, tTab2, tExtract()
'
If Not Intersect(Target, Range("A1")) Is Nothing Then
    tTab1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value
    tTab2 = Worksheets("Hiérarchie").Range("A2:A" & Worksheets("Hiérarchie").Range("A" & Rows.Count).End(xlUp).Row).Value
    ReDim tExtract(1 To UBound(tTab1, 1) * UBound(tTab2, 1), 1 To 2)
    For x = 1 To UBound(tTab1, 1)
        For y = 1 To UBound(tTab2, 1)
            tExtract(((x - 1) * UBound(tTab2, 1)) + y, 1) = tTab1(x, 1)
            tExtract(((x - 1) * UBound(tTab2, 1)) + y, 2) = tTab2(y, 1)
        Next
    Next
    With Worksheets("Extract")
        .Cells.Delete
        .Range("A1").Resize(1, 2).Value = Array("Clients", "Hiérarchie")
        .Range("A2").Resize(UBound(tExtract, 1), 2).Value = tExtract
        .Range("A1").Resize(1, 2).Interior.ColorIndex = 15
        .Range("A1").Resize(UBound(tExtract, 1) + 1, 2).Borders.LineStyle = xlContinuous
        .Columns.AutoFit
        .Activate
    End With
End If
'
End Sub

A+

C'est la première fois que je poste sur un forum pour demander de l'aide et je tiens vraiment à vous remercier grandement pour votre support !!

Bonne journée à tous et encore mille mercis!

Oops... oublié quelque chose...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

'

Dim tTab1, tTab2, tExtract()

'

If Not Intersect(Target, Range("A1")) Is Nothing Then

Cancel = True

tTab1 = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row).Value

tTab2 = Worksheets("Hiérarchie").Range("A2:A" & Worksheets("Hiérarchie").Range("A" & Rows.Count).End(xlUp).Row).Value

A+