VBA Excel Trier les données d'une feuille pour les répartir dans d'autres
Bonjour,
Je suis en train de me décourager au sujet d'une macro que je tente de faire fonctionner. Je ne suis pas vraiment bon, mais je lie énormément et j'essaie de faire fonctionner le tout.
J'ai présentement un fichier excel avec un onglet "Source" qui comprend toutes mes données sur 8 colonnes, mais plusieurs lignes. Ma troisième colonne est le numéro de "poste" de ces transactions. J'aimerais avoir une macro qui: 1) créer d'autres feuilles qui se nomment selon le noms des "postes" (exemple: 3005, 3006, 3007, etc.) et qui transfère les données du fichier source dans chacun des nouveaux onglets créés. J'ai essayé toute sorte de macros différentes et j'ai des demandes un peu plus spécifiques qui ne devraient pas être trop compliquées. Je veux que les données du fichier "source" demeurent également dans celui-ci, et je souhaite que lorsque j'ajoute des lignes dans mon fichier "source" et que je re-run ma macro, les données ne se réécrivent pas en double dans les feuilles. Il faut évidemment que la macro vérifie sur la worksheet à créer existe déjà.
Voici mon code actuel, mais celui-ci "cache" les données de "source" qui sont déjà traitées ... J'aimerais que les données demeurent.
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 3
Set ws = Sheets("Source")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:H1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub
Quelqu'un pourrait-il gentiment m'aider svp ?
Merci beaucoup !
WOW, ça semble fonctionner à la perfection. Merci énormément.
Deux petites choses cependant:
Dans l'onglet "source", le prix total fonctionne bien en multipliant le nb par le prix unitaire. Toutefois, lors du report dans les différents onglets, le total ne fonctionne pas correctement. Une idée pourquoi ?
Si jamais je dois "effacer" une ligne dans la source, est-ce qu'il existe une façon de le faire sans devoir effacer la ligne dans l'onglet "source" et également dans son onglet de poste ?
Merci encore
S
Ça fonctionne !! Merci
Si jamais je dois "effacer" une ligne dans la source, est-ce qu'il existe une façon de le faire sans devoir effacer la ligne dans l'onglet "source" et également dans son onglet de poste ?
Merci
S
Désolé mais je ne comprends pas ce que tu veux dire.
Bye !
Si je désire effacer une ligne de ma feuille "source", je dois également aller la supprimer dans l'onglet correspondant au poste (disons 3006). Si je l'efface seulement dans "source", elle demeure dans l'onglet qui a été préalablement créé qui correspondant à son numéro de poste (ex 3005, 3006, etc.)
Est-ce que existe une façon de faire pour que je l'efface seulement dans la feuille "source" et qu'elle s'efface également dans l'onglet correspondant au poste (disons 3006) ?
Merci
S
Merci tellement ! C'est exactement ce que je veux.
S
Salut !
J'ai réussi à avancer pas mal avec ce fichier grâce à ton aide.
Si je désire changer l'endroit (dans chaque feuille) où les données sont réparti, quelles sont les données que je dois modifier ? Présentement, le script réparti des donnés dans des nouveaux onglets (qu'il créé lui-même). Il les ligne écris à partir de A1. La ligne A c'est les titres de chaque colonnes et les lignes de données s'ajoutent par la suite.
Je voudrais toujours la même chose, mais j'aimerais que le données s'inscrivent de K à R. J'aimerais toujours avoir une ligne de titres de K1 à R1, et les données juste en dessous.
Voici mon script pour me dire quelles sont les données que je dois changer.
merci énormément.
Option Explicit
Dim f As Worksheet, fa As Worksheet, tablo
Dim i&, lgn&
Sub Répartir()
Set fa = ActiveSheet
tablo = Range("A1").CurrentRegion
Application.ScreenUpdating = False
For i = 2 To UBound(tablo, 1)
If fa.Range("I" & i) = "" Then
On Error Resume Next
Set f = Sheets(CStr(tablo(i, 1)))
If Err.Number <> 0 Then
Sheets.Add after:=Sheets("Liste")
ActiveSheet.Name = CStr(tablo(i, 1))
Set f = ActiveSheet
fa.Range("A1:H" & fa.Range("A" & Rows.Count).End(xlUp).Row).Copy f.Range("A1")
f.Range("A1").CurrentRegion.Offset(1, 0).ClearContents
fa.Range("A" & i & ":G" & i).Copy
f.Range("A2").PasteSpecial xlPasteValues
f.Range("H2").FormulaR1C1 = "=RC[-3]*RC[-1]"
Else
lgn = f.Range("A" & Rows.Count).End(xlUp)(2).Row
fa.Range("A" & i & ":G" & i).Copy
f.Range("A" & lgn).PasteSpecial xlPasteValues
f.Range("H" & lgn).FormulaR1C1 = "=RC[-3]*RC[-1]"
End If
End If
fa.Range("I" & i) = "R"
Application.CutCopyMode = False
Next i
fa.Activate
MsgBox "Travail terminé"
End Sub
Steve