Arrangement d'1 tableau sur 2 colonnes fixes

faneva

XLDnaute Nouveau
Bonjour,
J'ai déjà posté cette discussion mais avec 1 colonne fixe.
Lien supprimé
J'ai voulu adapter la solution de PierreJean mais il affiche un message d'erreur
Problème: j'ai 1 tableau avec de 16 colonnes dont les 2 se repetent
Je voudrais les mettre en colonne 1 et 2 et aligner les valeurs respectives
je ne vois pas ce qui ne marche pas
Merci de votre aide
Code:
Dim tablo As Variant
Dim m, n, derlin, deb, col As Long

Application.ScreenUpdating = False
'Range("A1065536").ClearContents
tablo = Range("A26")
Dim t()
ReDim t(1 To 5, 0)

For m = LBound(tablo, 2) To UBound(tablo, 2) Step 4
For n = LBound(tablo, 1) + 1 To UBound(tablo, 1)
If tablo(n, m) <> "" Then
t(1, UBound(t, 2)) = tablo(n, m)
t(2, UBound(t, 2)) = tablo(n, m + 1)
t(3, UBound(t, 2)) = tablo(n, m + 2)
t(4, UBound(t, 2)) = tablo(n, m + 3)



t(5, UBound(t, 2)) = tablo(1, m + 1)
ReDim Preserve t(1 To 5, UBound(t, 2) + 1)
End If
Next n
Next m

derlin = Range("A65536").End(xlUp).Row + 1

deb = derlin

For n = LBound(t, 2) To UBound(t, 2) - 1
Select Case t(5, n)
Case Range("c2")
col = 3
Case Range("g2")
col = 5
Case Range("k2")
col = 7
Case Range("o2")
col = 9

End Select
Cells(derlin, 1) = t(1, n)
Cells(derlin, 2) = t(2, n)
Cells(derlin, col) = t(3, n)
Cells(derlin, col + 1) = t(4, n)


derlin = derlin + 1
Next n

Range("A" & deb & ":t" & derlin - 1).Sort Key1:=Range("A7"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
For n = derlin - 1 To deb - 1 Step -1
If Range("A" & n) = Range("A" & n - 1) Then
If Range("B" & n) <> "" Then Range("B" & n - 1) = Range("B" & n)
If Range("c" & n) <> "" Then Range("c" & n - 1) = Range("c" & n)
If Range("d" & n) <> "" Then Range("d" & n - 1) = Range("d" & n)
If Range("e" & n) <> "" Then Range("e" & n - 1) = Range("e" & n)
If Range("f" & n) <> "" Then Range("f" & n - 1) = Range("f" & n)
If Range("g" & n) <> "" Then Range("g" & n - 1) = Range("g" & n)
If Range("h" & n) <> "" Then Range("h" & n - 1) = Range("h" & n)
If Range("i" & n) <> "" Then Range("i" & n - 1) = Range("i" & n)
If Range("j" & n) <> "" Then Range("j" & n - 1) = Range("j" & n)
If Range("k" & n) <> "" Then Range("k" & n - 1) = Range("k" & n)
If Range("l" & n) <> "" Then Range("l" & n - 1) = Range("l" & n)
If Range("m" & n) <> "" Then Range("m" & n - 1) = Range("m" & n)
If Range("n" & n) <> "" Then Range("n" & n - 1) = Range("n" & n)
If Range("o" & n) <> "" Then Range("o" & n - 1) = Range("o" & n)
If Range("p" & n) <> "" Then Range("p" & n - 1) = Range("p" & n)
If Range("q" & n) <> "" Then Range("q" & n - 1) = Range("q" & n)
If Range("r" & n) <> "" Then Range("r" & n - 1) = Range("r" & n)

Range("A" & n & ":r" & n).Delete
End If
Next n
Application.ScreenUpdating = True
 

Pièces jointes

  • tablo.zip
    13.5 KB · Affichages: 24
  • tablo.zip
    13.5 KB · Affichages: 25
  • tablo.zip
    13.5 KB · Affichages: 25

Discussions similaires

Réponses
11
Affichages
297

Statistiques des forums

Discussions
312 305
Messages
2 087 087
Membres
103 461
dernier inscrit
dams94