Modification macro

Le 07/03/2017 à 16:33

Bonjour à tous !

Je vous écrits aujourd'hui pour un problème de macro qui serait à adapter.

En pièce jointe un fichier nommé PI95_macro qui à partir du fichier PI95.csv faisait un classement des données.

Aujourd'hui nous avons le fichier PI125.csv qui est un peu différent du PI95.csv et du coup la macro ne fonctionne plus.

Est-ce que quelqu'un pourrait adapter la macro du fichier PI95_macro pour qu'elle fonctionne avec le fichier PI125.csv ?

Je vous remercie de votre en espérant que vous puissiez y arriver.

Merci à tous !

18pi95.zip (2.12 Ko)
13pi95macro.zip (49.86 Ko)
7pi125.csv (9.61 Ko)
Le 08/03/2017 à 01:53

Bonsoir,

Tu devrais être le mieux à même d'établir les nouvelles correspondances avec les données que tu prélèves dans le document source !

C'est l'essentiel du travail à faire, il est fastidieux, et il serait malvenu de le déléguer...

Par ailleurs ton code est du code enregistré... inutile de dire ce que j'en pense. Un tel code ne contient aucune commande VB, ce n'est que l'enregistrement de manipulations. Tu peux poursuivre dans la même voie, mais dans ce cas pas besoin de demander de l'aide pour enregistrer des manipulations...

Cordialement.

Le 09/03/2017 à 09:02

Bonjour MFerrand,

Merci de ta réponse mais hélas qui ne m'aide pas

Ce n'est pas moi qui est fait la macro du fichier PI95_macro et la personne n'est plus chez nous.

A ton avis il n'est pas possible d'adapter ce qui a été fait pour le nouveau format de fichier ?

Merci.

Le 09/03/2017 à 11:27

Bonjour,

Comme je l'ai dit, la première tâche est d'identifier quelles nouvelles colonnes correspondent aux anciennes ! Les en-têtes ayant changé, ce n'est pas de l'extérieur que l'on peut valablement faire cela ! Quelqu'un dont c'est le boulot doit avoir cette compétence... (sinon on se demande pourquoi l'entreprise le paie !!!)

Cordialement.

Le 24/03/2017 à 14:54

Bonjour,

j'ai recréé la macro pour modifier l'onglet "Download"

à partir de là il reste en transférer chaque groupe.

Sub test()
Call Delete_Sheet_Download
Call transform_Sheet1_to_Sheet_Download
'Call test_report
End Sub

Sub Delete_Sheet_Download()
Application.DisplayAlerts = False
Sheets("Download").Delete
End Sub

Sub transform_Sheet1_to_Sheet_Download()
Dim sh1, sh2, t1 As String, t2 As String
Dim n As Integer, i As Integer, y As Integer, x As Integer
Dim DerLign As Long, sh2LastCol As Integer
Dim liste()
'je vais utiliser une variable tableau et je choisi le nom ("liste") pour stoker les info "Titre Prénom, Nom"
'comme je ne connais pas d'avance le nombre de GuestName ("liste") à stoker, je n'ai rien mit entre les parentheses
'je vais allonger cette variable "liste" selon la boucle For i = 2 To DerLign
'avec la commande ReDim Preserve liste(i)

'Attribue une référence sh1 à al feuille "Sheet1"
Set sh1 = Sheets("Sheet1")
'détermine la dernière ligne de cette onglet
DerLign = sh1.Cells(Rows.Count, 1).End(xlUp).Row

'Ajout feuille "Download" et Attribue d'une référence sh2
Sheets.Add After:=Sheets(1) ' lors de l'ajout d'une feuille, celle-ci est automatiquement sélectionnée
ActiveSheet.Name = "Download"
Set sh2 = ActiveSheet

'boucle sur les GuestName de sh1("Sheet1")
'puis stoker les info sur la variable tableau "liste()"
sh1.Activate
For i = 2 To DerLign

 's'il y a un virgule
  If Not IsError(Application.Find(",", Range("C" & i))) Then
    t1 = Split(Range("C" & i), ",")(1) & " " & Split(Range("C" & i), ",")(0)
    ReDim Preserve liste(i - 1)
    liste(i - 1) = Application.Proper(Range("B" & i)) & " " & Application.Proper(Trim(t1))

    'sinon traiter l'espace
  Else
    n = Application.CountA(Range("C" & i), " ")
    For y = n - 1 To 0 Step -1
     t2 = t2 & Split(Range("C" & i), " ")(y) & " "
     ReDim Preserve liste(i - 1)
     liste(i - 1) = Application.Proper(Range("B" & i)) & " " & Application.Proper(Trim(t2))
    Next
  End If
  t1 = "" 'remise à 0 pour la prochaine donnée de GuestName
  t2 = "" 'remise à 0 pour la prochaine donnée de GuestName
Next

With sh2
 'transfert des données de la colonne A (Cabin) à la feuille "Download"
   .Range("B1:B" & DerLign).Value = sh1.Range("A1:A" & DerLign).Value
    With .Range("B1:B" & DerLign)
      .NumberFormat = "0000"
      .HorizontalAlignment = xlCenter

    End With

 'transfert des données des colonne D (ResCode) à la feuille "Download"
   .Range("D1:D" & DerLign).Value = sh1.Range("D1:F" & DerLign).Value

 'transfert des données des colonne B:C précédemment transformées en variable tableau liste() "Titre Prénom, Nom"
 'à la feuille "Download" colonne B
    .Range("C1").Resize(UBound(liste, 1) + 1) = Application.Transpose(liste)

 'ajuster largeur colonnes sur la feuille "Download"
    .Columns.AutoFit

 'select la feuille "Download"
    .Activate

'ajout d'une formule
    .Range("A2:A" & DerLign).Formula = "=SUMPRODUCT(--($B$2:$B$" & DerLign & "=B2)*($D$2:$D$" & DerLign & "=D2))"
End With

    Range("B2:D47").Select
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Download").Sort
        .SetRange Range("B2:D47")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'transforme Sheets("Download")pour les Guest
    n = 1
    For i = 2 To 10 Step 2
        n = n + 1
        Cells(1, i + 3) = "Guest " & n
        Cells(1, i + 4) = "Level " & n
    Next

For i = DerLign To 2 Step -1
 If Range("A" & i) > 1 Then
   x = Application.Match(Range("B" & i), Range("B:B"), -1)
    sh2LastCol = sh2.Cells(x, Columns.Count).End(xlToLeft).Column + 1
    Range("C" & i & ":D" & i).Copy Cells(x, sh2LastCol)
    Rows(i).Delete Shift:=xlUp
  End If
Next

'Call ajout_onglet
End Sub

oups, correction,

remplacer,

    Range("B2:D47").Select
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Download").Sort
        .SetRange Range("B2:D47")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

par

    Range("B2:D" & DerLign).Select
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Download").Sort
        .SetRange Range("B2:D" & DerLign)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
6test-modification-d-une-macro.xlsm (29.66 Ko)
Le 24/03/2017 à 15:14

comme on dit, jamais 2 sans trois

cette fois c'est bon!

remplacer

For i = DerLign To 2 Step -1

par

For i = DerLign + 1 To 2 Step -1
Le 26/03/2017 à 01:04

Bonjour,

j'ai ajouté à la macro la suite "classement des données"

Option Explicit

'nécessite l'activation de la bibliothèque Microsoft Scripting Runtime dans Outils\Références.

Sub test()
'Application.ScreenUpdating = False
Call Delete_Sheet_Download
Call transform_Sheet1_to_Sheet_Download
'Application.ScreenUpdating = True
End Sub

Sub Delete_Sheet_Download()
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Download").Delete
End Sub

Sub transform_Sheet1_to_Sheet_Download()
Dim sh1, sh2, t1 As String, t2 As String
Dim n As Integer, i As Integer, y As Integer, x, x0, x1, xx
Dim DerLign As Long, sh2LastCol As Integer, NbGuest As Integer
Dim it As Range, Plg As Range
Dim Dico As New Scripting.Dictionary, Cle, Valeur
Dim liste()

'Attribue une référence sh1 à al feuille "Sheet1"
Set sh1 = Sheets("Sheet1")
'détermine la dernière ligne de cette onglet
DerLign = sh1.Cells(Rows.Count, 1).End(xlUp).Row

'Ajout feuille "Download" et Attribue d'une référence sh2
Sheets.Add after:=Sheets(1) ' lors de l'ajout d'une feuille, celle-ci est automatiquement sélectionnée
ActiveSheet.Name = "Download"
Set sh2 = ActiveSheet

'boucle sur les GuestName de sh1("Sheet1")
'puis stoker les info sur la variable tableau "liste()"
sh1.Activate
For i = 2 To DerLign

 's'il y a un virgule
  If Not IsError(Application.Find(",", Range("C" & i))) Then
    t1 = Split(Range("C" & i), ",")(1) & " " & Split(Range("C" & i), ",")(0)
    ReDim Preserve liste(i - 1)
    liste(i - 1) = Application.Proper(Range("B" & i)) & " " & Application.Proper(Trim(t1))

    'sinon traiter l'espace
  Else
    n = Application.CountA(Range("C" & i), " ")
    For y = n - 1 To 0 Step -1
     t2 = t2 & Split(Range("C" & i), " ")(y) & " "
     ReDim Preserve liste(i - 1)
     liste(i - 1) = Application.Proper(Range("B" & i)) & " " & Application.Proper(Trim(t2))
    Next
  End If
  t1 = "" 'remise à 0 pour la prochaine donnée de GuestName
  t2 = "" 'remise à 0 pour la prochaine donnée de GuestName
Next

 'transfert des données de la colonne A (Cabin) à la feuille "Download"
  With sh2
   .Range("B1:B" & DerLign).Value = sh1.Range("A1:A" & DerLign).Value
    With .Range("B1:B" & DerLign)
      .NumberFormat = "0000"
      .HorizontalAlignment = xlCenter
  End With

 'transfert des données des colonne D (ResCode) à la feuille "Download"
   .Range("D1:D" & DerLign).Value = sh1.Range("D1:F" & DerLign).Value

 'transfert des données des colonne B:C précédemment transformées en variable tableau liste() "Titre Prénom, Nom"
 'à la feuille "Download" colonne B
    .Range("C1").Resize(UBound(liste, 1) + 1) = Application.Transpose(liste)

 'select la feuille "Download"
    .Activate

 'ajout d'une formule sur la feuille "Download" pour trouver les doublons Guest
    .Range("A2:A" & DerLign).Formula = "=SUMPRODUCT(--($B$2:$B$" & DerLign & "=B2)*($D$2:$D$" & DerLign & "=D2))"
End With

' tri de la plage en ordre décroissant
    Range("B2:D" & DerLign).Select
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Download").Sort.SortFields.Add Key:=Range("B2"), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortTextAsNumbers
    With ActiveWorkbook.Worksheets("Download").Sort
        .SetRange Range("B2:D" & DerLign)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
Range("A1").Select

'déplacement des Guest au niveau "Level 1 à Level x"
For i = DerLign + 1 To 2 Step -1
 If Range("A" & i) > 1 Then
   x = Application.Match(Range("B" & i), Range("B:B"), -1)
    sh2LastCol = sh2.Cells(x, Columns.Count).End(xlToLeft).Column + 1
    Range("C" & i & ":D" & i).Copy Cells(x, sh2LastCol)
    Rows(i).Delete Shift:=xlUp
  End If
Next

'inscription des titres de colonnes Guest et Level
NbGuest = (Cells.SpecialCells(xlCellTypeLastCell).Column)
    n = 1
    Cells(1, 3) = "Guest 1"
    For i = 2 To NbGuest - 4 Step 2
        n = n + 1
        Cells(1, i + 3) = "Guest " & n
        Cells(1, i + 4) = "Level " & n
    Next

'ajuster largeur colonnes
  sh2.Columns.AutoFit

'créer un dico des Rescode sans doublon
'nécessite l'activation de la bibliothèque Microsoft Scripting Runtime dans Outils\Références.
For i = 2 To sh2.Cells(Rows.Count, 1).End(xlUp).Row
    Cle = Range("D" & i)
    Valeur = ""
    If Not Dico.Exists(Cle) Then
     Dico.Add Cle, Valeur
    End If
Next

'creer les onglets ResCode et transfert des données
 sh2.Range("B1").AutoFilter

For i = 0 To Dico.Count - 1
  Set Plg = ActiveSheet.Range("_filterdatabase").SpecialCells(xlCellTypeVisible)
  ActiveSheet.Range(Plg.Address).AutoFilter Field:=4, Criteria1:=Dico.Keys(i)
  Sheets.Add after:=Sheets(Sheets.Count)
  ActiveSheet.Name = Dico.Keys(i)
  sh2.Range("_FilterDatabase").SpecialCells(xlCellTypeVisible).Copy Range("A1")
  ActiveSheet.Columns.AutoFit
  sh2.Activate
Next
sh2.Range("B1").AutoFilter
End Sub
8test-modification-d-une-macro.xlsm (32.06 Ko)
Rechercher des sujets similaires à "modification macro"