Macro Excel pour MSProject
Bonjour à tous
Je viens sur ce Forum car j'ai besoin d'une grande aide:
Je suis actuellement en stage et ma mission est de lié Excel à MS Project.
et pour cela je dois modifier mon tableau de base pour que MS Project puisse le lire.
DOnc j'ai réaliser une macro qui me permet de transposer mes données mais je voudrai que certaines données reste sur la même ligne mais pas sur celles transposer(je m'explique mal je penses
Et je voudrai le réaliser avec une macro du à mes nombreuses valeurs.
Bonjour,
Sub test()
Dim sh1LastRw As Long, sh2LastRw As Long, i As Long, y As Long
Dim sh1, sh2
Set sh1 = Sheets("Feuil1")
Set sh2 = Sheets("Feuil2")
sh1LastRw = sh1.Cells(Rows.Count, 1).End(xlUp).Row
sh2.Range("A1:C1").Value = sh1.Range("A1:C1")
For i = 2 To sh1LastRw
If Application.CountA(sh1.Range("B" & i & ":K" & i)) <> 0 Then
sh2LastRw = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh2.Cells(sh2LastRw, 1).Value = sh1.Cells(i, 1).Value
sh2.Cells(sh2LastRw, 2).Value = sh1.Cells(i, 12).Value
sh2.Cells(sh2LastRw, 3).Value = sh1.Cells(i, 13).Value
For y = 2 To 11
sh2LastRw = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh2.Cells(sh2LastRw, 1).Value = sh1.Cells(i, y).Value
Next
End If
Next
End Subbonjour,
Merci beaucoup c'est exactement ce qu'il me fallait.
cordialement
Bonjour,
désolé, tu aurais eu une réponse plus rapide en posant la question dans le fil initial.
je pense rarement à regarder si j'ai des messages en bal
de plus je ne parvient pas à envoyer un message à partir de cette bal
voici la modification,
Sub test()
Dim sh1LastRw As Long, sh2LastRw As Long, i As Long, y As Long
Dim sh1, sh2, p As Integer, r As Integer, d As Integer, op As Integer
Set sh1 = Sheets("Feuil1")
Set sh2 = Sheets("Feuil2")
p = Application.Match("pièces", sh1.Range("1:1"), 0)
r = Application.Match("recues", sh1.Range("1:1"), 0)
d = Application.Match("délai", sh1.Range("1:1"), 0)
op = 10 'opérateurs
sh1LastRw = sh1.Cells(Rows.Count, p).End(xlUp).Row
sh2.Range("A1").Value = sh1.Cells(1, p)
sh2.Range("B1").Value = sh1.Cells(1, r)
sh2.Range("C1").Value = sh1.Cells(1, d)
For i = 2 To sh1LastRw
If Application.CountA(sh1.Range(Cells(i, p + 1).Address, Cells(i, p + op).Address)) <> 0 Then
sh2LastRw = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh2.Cells(sh2LastRw, 1).Value = sh1.Cells(i, p).Value
sh2.Cells(sh2LastRw, 2).Value = sh1.Cells(i, r).Value
sh2.Cells(sh2LastRw, 3).Value = sh1.Cells(i, d).Value
For y = p + 1 To p + op
sh2LastRw = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
sh2.Cells(sh2LastRw, 1).Value = sh1.Cells(i, y).Value
Next
End If
Next
End SubBonjour,
Je ne pensais qu'il s'agissait encore de ce sujet car pour cette mission j'avais réaliser cette macro :
[*]Sub recopier()
'fait en mai 2017
'pour afficher directement le résultat
Application.ScreenUpdating = False
'déclaration des variables
Dim lig, li, col As Integer
'nombre de lignes du tableau onglet final
li = Sheets("final").Range("A65000").End(xlUp).Row
'on efface les données colonne A,B,C de l'onglet final
Sheets("final").Range("A3:C" & li + 1).ClearContents
'on crée une feuille nommée base
Application.DisplayAlerts = False
On Error Resume Next
Sheets("base").Delete
Sheets("départ").Select
Sheets("départ").Copy Before:=Sheets("final")
Sheets("départ (2)").Select
Sheets("départ (2)").Name = "base"
Range("B3").Select
Application.DisplayAlerts = True
Range("K2").Select
li = 1
'nombre de lignes du tableau départ
Do While li <= Range("K2").End(xlDown).Row
co = 12
k = 0
'on teste sur 15 colonnes opérateurs si vide k=0
Do While co <= 26
If Cells(li, co) <> "" Then k = k + 1
co = co + 1
Loop
'on efface la ligne vide
If k = 0 Then Rows(li).Delete: li = li - 1
li = li + 1
Loop
'lig-col du tableau départ de la base
lig = Range("K2").End(xlDown).Row
col = 26 '
Range(Cells(2, 11), Cells(lig, col)).Select
'on recopie dans la feuille final en A2
li = 1
For Each cel In Selection
If cel = "" Then GoTo suite
li = li + 1
Sheets("final").Range("A" & li) = cel
suite:
Next
' on recopie les dates
For i = 2 To lig
For j = 2 To li
If Sheets("final").Range("A" & j) = Sheets("base").Range("K" & i) Then
Sheets("final").Range("B" & j) = Sheets("base").Range("AB" & i) 'date reçues
Sheets("final").Range("C" & j) = Sheets("base").Range("AD" & i) ' délai 1 mois
GoTo suite1
End If
Next
suite1:
Next
Range("B1").Select
Sheets("final").Select
Columns("A:C").Select
Selection.Interior.ColorIndex = xlNone
Range("A2:A" & li).Select
Selection.Interior.ColorIndex = 35
'mise en forme +couleur
Range("A1:C" & li).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1:C1").Select
With Selection.Interior
.ColorIndex = 40
.Pattern = xlSolid
End With
Range("A1").Select
Application.ScreenUpdating = True
End Sub[*]
Elle correspond au but de ma mission mais une autre la suit de prêt :
maintenant la macro que je veux réaliser corespond à un transfert de données entre deux feuilles je l'explique mieux dans mon document.