Copie de tableau en horizontal
Bonjour à tous,
Ci-joint, vous trouverez un fichier excel reprenant un exemple de mon problème.
Comme vous pourrez le voir, j'ai une liste de tableau un en dessous des autres (dans le fichier original, j'en ai plus de 4000). L'idée est d'utiliser une macro afin de reprendre chaque tableau (de "Order" à "Resolved Name" et collone A et B) et de les coller un a côté des autres.
Le nombre de ligne par tableau n'est bien entendu pas égale pour chaque (Des lignes se rajoutent ou s'enlèvent à la ligne "Adresse"). Par contre, Ils commencent tous par "Order" (en colonne A) avec un numéro (en B) qui se suit (1, 2, 3, ... jusque +4000) et finit par la ligne "Resolved Name".
De cette manière je pourrais effectuer une recherche horizontal et utiliser toutes ces données.
J'espère que mon explication est claire. Sinon, n'hésitez pas .. Je ferai un dessin
Merci d'avance à tous de votre temps.
Romain.
Super !
J'essaye ca dès demain et vous tiens au courant
merci de votre temps et de la réactivité !!!
Bonsoir RmZ, d3d9x, le forum
Je verrais les choses de cette manière, tous les champs sont alignés.
Restitution dans la 3ème feuille.
Option Explicit
Sub test()
Dim myareas As Areas, myArea As Range, x As Byte, y As Byte, t As Long
Sheets(3).Cells(1).CurrentRegion.Clear
On Error Resume Next
With Sheets(1).Range("a1", Sheets(1).Range("a" & Rows.Count).End(xlUp))
Set myareas = .SpecialCells(2).Areas
End With
On Error GoTo 0
If myareas Is Nothing Then Exit Sub
For Each myArea In myareas
x = Application.Match("Postal Code", myArea, 0)
y = Application.Max(x, y)
Next
Application.ScreenUpdating = False
t = 1
For Each myArea In myareas
x = Application.Match("Postal Code", myArea, 0)
myArea.Resize(x - 1, 2).Copy Sheets(3).Cells(1, t)
myArea.Offset(x - 1).Resize(myArea.Rows.Count - x + 1, 2).Copy Sheets(3).Cells(y, t)
t = t + 2
Next
With Sheets(3).Cells(1)
With .CurrentRegion
.UnMerge
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.Interior.ColorIndex = 38
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
Set myareas = Nothing
End Subklin89
Re le forum,
Une autre façon de procéder :
Option Explicit
Sub test()
Dim myareas As Areas, myArea As Range, b(), p1 As Byte, p As Byte
Dim i As Byte, dif As Byte, n As Byte, t As Long
On Error Resume Next
With Sheets(1).Range("a1", Sheets(1).Range("a" & Rows.Count).End(xlUp))
Set myareas = .SpecialCells(2).Areas
'.SpecialCells(2).Select
End With
On Error GoTo 0
If myareas Is Nothing Then Exit Sub
For Each myArea In myareas
n = Application.Max(myArea.Rows.Count, n)
p = Application.Max(Application.Match("Postal Code", myArea, 0), p)
Next
ReDim b(1 To n, 1 To myareas.Count * 2)
For Each myArea In myareas
p1 = Application.Match("Postal Code", myArea, 0)
For i = 1 To p1 - 1
b(i, 1 + t) = myArea(i, 1).Value
b(i, 2 + t) = myArea(i, 2).Value
Next
dif = p - p1
For i = p To n
b(i, 1 + t) = myArea(i - dif, 1).Value
b(i, 2 + t) = myArea(i - dif, 2).Value
Next
t = t + 2
Next
Application.ScreenUpdating = False
With Sheets(3).Cells(1)
.CurrentRegion.Clear
.Resize(UBound(b, 1), UBound(b, 2)) = b
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
With .Rows(1)
.Interior.ColorIndex = 38
End With
With .Range(.Cells(12, 1), .Cells(p - 1, .Columns.Count))
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
.Columns.AutoFit
End With
.Parent.Activate
End With
Application.ScreenUpdating = True
Set myareas = Nothing
End Subklin89