Regrouper les valeurs lignes en deux colonnes
bonjour,
Je me tourne à nouveaux vers vous pour m'aider à trouver la solution.
J'importe un fichier .XML et je le colle dans une feuille .xlsm. Ce dernier contient, en colonne A, des positions de travail et dans les colonnes (de H à W) des noms(modifiés).
Mon but est de mettre en colonne Z les noms, en AA leur position en vac1( lignes 9 à 30 mais qui peux varier) et en colonne AB leur position en vac2( lignes 31 à 51 qui peux varier aussi) le tout sans cellule vide ni point.
Je joint mon fichier où j'ai copié-collé la vac1 que je souhaiterai obtenir par formule( si possible car je suis nul en VBA)
Merci d'avance
Cordialement
Bonsoir etsije,,le forum
Avec des données importées, je te conseille de commencer par un bon nettoyage
Je ne suis pas parvenu à identifier le caractère unique en colonnes H, J et suivantes, je les ai effacés manuellement.
Option Explicit
Sub test()
Dim a, i As Long, j As Long, n As Long, w, col As Byte
With Sheets("import xaq").Range("a9:w51")
a = .Value
ReDim b(1 To .Cells.Count, 1 To 3)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
If UCase(Left(a(i, 1), 4)) = "VAC1" Then col = 2 Else col = 3
For j = 9 To UBound(a, 2)
If Not IsEmpty(a(i, j)) And a(i, j) <> "" Then
If Not .exists(a(i, j)) Then
n = n + 1
.Item(a(i, j)) = n
b(n, 1) = a(i, j): b(n, col) = a(i, 1)
Else
w = .Item(a(i, j))
b(w, col) = a(i, 1)
.Item(a(i, j)) = w
End If
End If
Next
Next
End With
End With
Application.ScreenUpdating = False
With Sheets.Add.Cells(1)
.Resize(1, 3) = Array("Noms", "Vac1", "Vac2")
With .Offset(1).Resize(n, UBound(b, 2))
.Value = b
.Columns.AutoFit
End With
With .CurrentRegion
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 40
End With
End With
End With
Application.ScreenUpdating = True
End Subklin89
Bonjour Klin89 ainsi qu'au forum
Un immense merci pour la solution proposée qui me conviens parfaitement
Lorsque tu me dit que tu as éliminé manuellement, cela veux dire que tu as sélectionné toutes les cellules contenant le point noir?
Est-ce que si je nettoie en supprimant les colonnes contenant ces points ton code va toujours être valable(j'ai essayé et des noms n'apparaissent plus) si non que faut il modifier?
(suppression des colonnes D,F,G,H,J,L,N,P,R,S)
Encore merci
Cordialement
Re etsije,
Pour le traitement de tes données, je peux ignorer les colonnes inutiles en redéfinissant la variable a comme ceci :
With Sheets("import xaq").Range("a9:w51")
a = Application.Index(.Value, Evaluate("row(1:" & _
.Rows.Count & ")"), Array(1, 9, 11, 13, 15, 17, 20, 22))à la place de :
With Sheets("import xaq").Range("a9:w51")
a = .ValueEn attendant, vois ce nouveau code qu'il faudra réajuster au cas où.
Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long, t As Long, dico As Object, txt As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("import xaq").Range("a9:w51")
a = .Value
ReDim b(1 To .Cells.Count, 1 To 1)
b(1, 1) = "Noms": n = 1: t = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
txt = Left(a(i, 1), 4)
If Not dico.exists(txt) Then
t = t + 1
dico(txt) = t
If UBound(b, 2) < t Then
ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 10)
End If
b(1, t) = txt
End If
For j = 9 To UBound(a, 2)
If a(i, j) <> "" Then
If Not .exists(a(i, j)) Then
n = n + 1
.Item(a(i, j)) = n
b(n, 1) = a(i, j)
End If
b(.Item(a(i, j)), dico(txt)) = a(i, 1)
End If
Next
Next
End With
End With
Set dico = Nothing
Application.ScreenUpdating = False
With Sheets.Add.Cells(1).Resize(n, t)
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 40
End With
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Subklin89
Bonsoir Klin89, bonsoir le forum
C'est exactement ce que je souhaitais, je te remercie vraiment beaucoup je n'y serais jamais arrivé.
Je vais abuser de ton temps, si je supprimais les colonnes D,F,G,H,J,L,N,P,R,S au lieu de les "ignorer" ça rendrait le fichier plus lisible à l'impression.
Est ce que tu aurais encore un peu de temps à m'accorder
Un énorme merci
Très cordialement
Re etsije,
J'ai surligné les changements.
Option Explicit
Sub test()
Dim a, b(), i As Long, j As Long, n As Long, t As Long, dico As Object, txt As String
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("import xaq").Range("a9:n51")
a = .Value
ReDim b(1 To .Cells.Count, 1 To 1)
b(1, 1) = "Noms": n = 1: t = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 1 To UBound(a, 1)
If a(i, 1) = "" Then a(i, 1) = a(i - 1, 1)
txt = Left(a(i, 1), 4)
If Not dico.exists(txt) Then
t = t + 1
dico(txt) = t
If UBound(b, 2) < t Then
ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 10)
End If
b(1, t) = txt
End If
'boucle de la colonne 8 à 14
For j = 8 To UBound(a, 2)
If a(i, j) <> "" Then
If Not .exists(a(i, j)) Then
n = n + 1
.Item(a(i, j)) = n
b(n, 1) = a(i, j)
End If
b(.Item(a(i, j)), dico(txt)) = a(i, 1)
End If
Next
Next
End With
End With
Set dico = Nothing
Application.ScreenUpdating = False
With Sheets.Add.Cells(1).Resize(n, t)
.Value = b
.Font.Name = "calibri"
.Font.Size = 10
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThin
.Borders(xlInsideVertical).Weight = xlThin
With .Rows(1)
.BorderAround Weight:=xlThin
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 40
End With
.Columns.AutoFit
End With
Application.ScreenUpdating = True
End SubPourquoi toutes ces cellules fusionnées
klin89
Bonsoir Klin89, le forum
Ca fonctionne du tonnerre, un immense merci. Les petites explications m'ont beaucoup aidé à comprendre
Merci à toi, merci au forum
PS: si je voulais me lancer dans VBA, que me conseille tu comme support pour les + que nuls
Très cordialement