Fusion tableaux selon lignes
Bonjour,
Je pense que ma question ne doit pas être très difficile, mais me débrouillant mal pour ce genre de choses sur excel, j'aurais besoin de votre aide.
Je dispose de deux tableaux, d'environ 57000 lignes chacun. Chaque colonne représente un individu, chaque ligne un gène. Chaque gène n'étant pas forcément présent dans les deux tableaux. Je souhaiterais pouvoir les fusionner de cette manière :
Tab1 :
| Ind1 | Ind2 | Ind3 | |
| gène1 | x | x | x |
| gène2 | x | x | x |
| gène4 | x | x | x |
Tab2 :
| Ind4 | Ind2 | Ind5 | |
| gène1 | x | x | x |
| gène2 | x | x | x |
| gène3 | x | x | x |
Resultats :
| Ind1 | Ind2 | Ind3 | Ind4 | Ind2 | Ind5 | |
| gène1 | x | x | x | x | x | x |
| gène2 | x | x | x | x | x | x |
| gène3 | x | x | x | |||
| gène4 | x | x | x |
J'ai vu la fonction "RECHERCHEH", mais elle ne permet pas de garder les gènes qui ne sont pas présents dans l'un ou l'autre.
Merci d'avance pour votre aide.
Corentin R.
Bonjour et bienvenue sur le forum
Confirmes-tu que Ind2 revient deux fois dans le tableau de Résultats, une fois en colonne 3 et une autre fois en colonne 6 ?
A te relire.
Bye !
Bonjour à tous,
Je me pose la même question que gmb 8) et ne vois pas l'intérêt de cette présentation
Je vois plutôt les choses de cette façon.
Restitution en Feuil3 :
Option Explicit
Sub test()
Dim a, i As Long, j As Long, x As Long, AL As Object, e
Set AL = CreateObject("System.Collections.ArrayList")
With CreateObject("Scripting.Dictionary")
For Each e In Array("Feuil1", "Feuil2")
a = Sheets(e).Cells(1).CurrentRegion.Value
For j = 2 To UBound(a, 2)
If Not AL.Contains(a(1, j)) Then AL.Add a(1, j)
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(1, j)) = "x"
Next
Next
Next
x = .Count + 1
ReDim a(1 To x, 1 To AL.Count + 1)
For i = 0 To AL.Count - 1
a(1, i + 2) = AL(i)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .keys()(i)
For j = 0 To .items()(i).Count - 1
a(i + 2, AL.IndexOf(.items()(i).keys()(j), 0) + 2) = .items()(i).items()(j)
Next
Next
End With
Application.ScreenUpdating = False
With Sheets("Feuil3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.CurrentRegion.Clear
.Value = a
With .Rows(1)
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 36
End With
.BorderAround Weight:=xlThin
End With
With .Columns(1)
With .Offset(1).Resize(.Rows.Count - 1)
.Interior.ColorIndex = 43
End With
End With
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Parent.Activate
End With
Application.ScreenUpdating = True
End Subklin89
Re CorentinR,
Comme ceci, ça devrait le faire.
Dans ton fichier original, fixe bien la 1ère dimension de la variable tableau b.
Option Explicit
Sub test()
Dim a, b(), e, i As Long, j As Long
Dim n As Long, t As Long, col As Long
'attention à la 1ère dimension
ReDim b(1 To 10, 1 To 1): n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For Each e In Array("Feuil1", "Feuil2")
a = Sheets(e).Cells(1).CurrentRegion.Value
t = UBound(a, 2) - 1: col = UBound(b, 2)
ReDim Preserve b(1 To UBound(b, 1), 1 To col + t)
For j = 2 To UBound(a, 2)
b(1, col - 1 + j) = a(1, j)
Next
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
n = n + 1: .Item(a(i, 1)) = n
b(n, 1) = a(i, 1)
For j = 2 To UBound(a, 2)
b(n, col - 1 + j) = a(i, j)
Next
Else
For j = 2 To UBound(a, 2)
b(.Item(a(i, 1)), col - 1 + j) = a(i, j)
Next
End If
Next
Next
End With
Application.ScreenUpdating = False
With Sheets("Feuil3").Cells(1).Resize(n, UBound(b, 2))
.CurrentRegion.Clear
.Value = b
With .Rows(1)
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 36
End With
.BorderAround Weight:=xlThin
End With
With .Columns(1)
With .Offset(1).Resize(.Rows.Count - 1)
.Interior.ColorIndex = 43
End With
End With
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Parent.Activate
End With
Application.ScreenUpdating = True
End Subklin89
Re
j'ai réjusté le 1er code :
Option Explicit
Sub test()
Dim a, i As Long, j As Long, x As Long, AL As Object, e, el
Set AL = CreateObject("System.Collections.ArrayList")
With CreateObject("Scripting.Dictionary")
For Each e In Array("Feuil1", "Feuil2")
a = Sheets(e).Cells(1).CurrentRegion.Value
For j = 2 To UBound(a, 2)
AL.Add a(1, j) & "," & e
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
Set .Item(a(i, 1)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 1)).CompareMode = 1
End If
.Item(a(i, 1))(a(1, j) & "," & e) = a(i, j)
Next
Next
Next
x = .Count + 1
ReDim a(1 To x, 1 To AL.Count + 1)
For i = 0 To AL.Count - 1
el = Split(AL(i), ",")
a(1, i + 2) = el(0)
Next
For i = 0 To .Count - 1
a(i + 2, 1) = .keys()(i)
For j = 0 To .items()(i).Count - 1
a(i + 2, AL.IndexOf(.items()(i).keys()(j), 0) + 2) = .items()(i).items()(j)
Next
Next
End With
Application.ScreenUpdating = False
With Sheets("Feuil3").Cells(1).Resize(UBound(a, 1), UBound(a, 2))
.CurrentRegion.Clear
.Value = a
With .Rows(1)
With .Offset(, 1).Resize(, .Columns.Count - 1)
.Interior.ColorIndex = 36
End With
.BorderAround Weight:=xlThin
End With
With .Columns(1)
With .Offset(1).Resize(.Rows.Count - 1)
.Interior.ColorIndex = 43
End With
End With
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Parent.Activate
End With
Application.ScreenUpdating = True
End Subklin89