Comment aligner les doublons sur les mêmes lignes dans Excel en VBA

Voici ma situation ..Comment aligner les doublons sur les mêmes lignes dans Excel en VBA

Je fichier:

1004 Dr Margarita Solorzano Olabarria SILVER 228230185  
    1004 Mr Jose Manuel Santos Aboim Inglez BRONZE 236338858  
    1007 Mrs Amanda De Souza Rodrigues  BRONZE 238246729  
    1007 Mr Eduardo Jaime Smejoff   BRONZE 214046768  
    1010 Mrs Genevieve Thie     PLATIN 221093078 
    1010 Mrs Mary Wilson      PLPLUS 21384102  
    1203 Ms Valerie Harrison     BRONZE 207754414  
    1203 Ms Joy Bridget Moncrieff   BRONZE 207754415

avec la colonne A: n ° de cabine

Colonne B : M. ou Mme

Colonne C: Première & Nom

Col UMN D: Statut (bronze, argent etc ...)

Colonne E: Numéro d'adhésion

Si la colonne A sont les mêmes que je le veux sur la même ligne. mais elle ne comprend pas Bronze Statut, Argent, Or, Alors je mets dans mon VBA pour exclure ceux-ci:

ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")"

Quand je lance les macros il me gaves ceci:

1211 Mr Thomas Buettner PLPLUS Mr Heinz Juergen Nolte PLPLUS 
4011 Mr Michael Brent PLATIN Mrs Wilhelmina Johanna PLATIN 
4013 Mrs Nancy Jean  PLATIN Mr James    PLATIN 
4034 Mr Donald Meyer PLATIN Mrs Marcia Meyer  PLATIN 
1010 Mrs Genevieve Thie PLATIN 
1010 Mrs Mary Wilson PLPLUS

Regardez le nombre 1010 ..

D'une certaine façon les deux sont dans la condition, mais parce qu'ils ont un statut différent, la macro les mettre dans une autre ligne et je ne veux pas que, je les veux dans la même rangée ..

Pouvez-vous me aider ..

Ajouté le 7 mars Voici mon ensemble Macro (Je ne veux pas un autre Sub):

Sub LATDownloadMACROS() 
' 
' LATDownloadMACROS Macro 
' Macro recorded 02/25/2017 by Johan Esteve 


' Debut Macro 
Cells.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortTextAsNumbers 
Cells.EntireColumn.AutoFit 
Columns("D:D").Insert Shift:=xlToRight 
Columns("C:C").TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True 
Columns("E:E").Insert Shift:=xlToRight 
Range("E2").FormulaR1C1 = "=PROPER(RC[-3])&"" ""&PROPER(RC[-1])&"" ""&PROPER(RC[-2])" 
Range("E2").AutoFill Destination:=Range("E2:E4200"), Type:=xlFillDefault 
Range("E2:E4200").Select 
Columns("E:E").Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
Columns("B:D").Select 
Range("D1").Activate 

Application.CutCopyMode = False 
Selection.Delete Shift:=xlToLeft 
Range("B18").Select 
Sheets("Sheet1").Select 
Sheets.Add 
Sheets("Sheet1").Select 
Sheets("Sheet1").Name = "Download" 
Sheets("Download").Select 
Cells.Select 
Selection.Copy 
Sheets("Sheet2").Select 
Cells.Select 
ActiveSheet.Paste 
Range("B1").Select 

Application.CutCopyMode = False 
ActiveCell.FormulaR1C1 = "Guest 1" 
Range("C1").FormulaR1C1 = "Level1" 
Range("D1").FormulaR1C1 = "Guest 2" 
Range("E1").FormulaR1C1 = "Level2" 
Range("F1").FormulaR1C1 = "Guest 3" 
Range("G1").FormulaR1C1 = "Level3" 
Range("F1:G1").AutoFill Destination:=Range("F1:M1"), Type:=xlFillDefault 

Range("D1").FormulaR1C1 = "Guest 2" 
Range("D2").FormulaR1C1 = "=IF(RC[-3]=R[-1]C[-3],RC[-2],"""")" 
Range("E2").FormulaR1C1 = "=IF(RC[-4]=R[-1]C[-4],RC[-2],"""")" 
Range("D2").FormulaR1C1 = "=IF(R[1]C[-3]=RC[-3],R[1]C[-2],"""")" 
Range("E2").FormulaR1C1 = "=IF(R[1]C[-4]=RC[-4],R[1]C[-2],"""")" 
Range("F2").FormulaR1C1 = "=IF(R[2]C[-5]=RC[-5],R[2]C[-4],"""")" 
Range("G2").FormulaR1C1 = "=IF(R[2]C[-6]=RC[-6],R[2]C[-4],"""")" 
Range("H2").FormulaR1C1 = "=IF(R[3]C[-7]=RC[-7],R[3]C[-6],"""")" 
Range("I2").FormulaR1C1 = "=IF(R[3]C[-8]=RC[-8],R[3]C[-6],"""")" 
Range("J2").FormulaR1C1 = "=IF(R[4]C[-9]=RC[-9],R[4]C[-8],"""")" 
Range("K2").FormulaR1C1 = "=IF(R[4]C[-10]=RC[-10],R[4]C[-8],"""")" 
Range("L2").FormulaR1C1 = "=IF(R[5]C[-11]=RC[-11],R[5]C[-10],"""")" 
Range("M2").FormulaR1C1 = "=IF(R[5]C[-12]=RC[-12],R[5]C[-10],"""")" 
Range("D2:M2").AutoFill Destination:=Range("D2:M4200"), Type:=xlFillDefault 
Range("D2:M4200").Select 

Columns("D:M").AutoFit 
Sheets("Sheet2").Move Before:=Sheets(1) 

Sheets("Sheet2").Select 
Sheets("Sheet2").Copy Before:=Sheets(2) 
Sheets("Sheet2 (2)").Select 
Range("D2").Select 
Sheets("Sheet2").Select 
Columns("D:M").Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

Columns("A:A").Select 

Application.CutCopyMode = False 
Selection.Insert Shift:=xlToRight 
Range("A2").FormulaR1C1 = "=IF(RC[1]=R[-1]C[1],""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault 
Range("A2:A6").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 
Columns("A:A").Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
Cells.Select 

Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 

Sheets("Sheet2 (2)").Select 
Columns("A:C").Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Columns("A:A").Insert Shift:=xlToRight 

Range("A2").FormulaR1C1 = "=if" 
Range("A2").FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""BRONZE"",RC[3]=""SILVER""),""Delete"","""")" 

Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 

Columns("A:A").Select 
Sheets("Sheet2 (2)").Select 
Sheets.Add 
Sheets("Sheet4").Select 
Sheets("Sheet4").Move After:=Sheets(3) 
Sheets("Sheet2").Select 
Sheets("Sheet2").Name = "Champagne" 
Sheets("Sheet2 (2)").Select 
Sheets("Sheet2 (2)").Name = "Water" 
Columns("E:N").Copy 

Sheets("Sheet4").Select 
Range("D1").Select 
ActiveSheet.Paste 
Range("D2").Select 
Sheets("Water").Select 
Cells.Select 
Application.CutCopyMode = False 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Sheets("Download").Select 
Selection.Copy 
Columns("A:C").Select 
Application.CutCopyMode = False 
Selection.Copy 
Sheets("Sheet4").Select 
Columns("A:C").Select 
ActiveSheet.Paste 

' Ambassador 
Application.CutCopyMode = False 
Selection.Sort Key1:=Range("C2"), Order1:=xlDescending, Key2:=Range("A2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Columns("A:A").Insert Shift:=xlToRight 
Range("A1").FormulaR1C1 = "" 
Range("A2").Select 
Sheets("Sheet4").Select 
Sheets("Sheet4").Copy Before:=Sheets(3) 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Move After:=Sheets(4) 
Sheets("Sheet4").Select 
Sheets("Sheet4").Name = "Ambassador" 
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLATIN"",RC[3]=""PLPLUS""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 
Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

Sheets("Ambassador").Select 
Rows("2:4200").Select 
Range(Selection, Selection.End(xlDown)).Select 
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Clear 
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Add Key:=Range(_ 
    "A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ 
    xlSortNormal 
ActiveWorkbook.Worksheets("Ambassador").Sort.SortFields.Add Key:=Range(_ 
    "B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ 
    xlSortTextAsNumbers 
With ActiveWorkbook.Worksheets("Ambassador").Sort 
    .SetRange Range("A2:O4200") 
    .Header = xlGuess 
    .MatchCase = False 
    .Orientation = xlTopToBottom 
    .SortMethod = xlPinYin 
    .Apply 
End With 
Rows("1:1").Select 

' Chocolate 
Application.CutCopyMode = False 
Selection.Sort Key1:=Range("B2"), Order1:=xlDescending, Key2:=Range("C2"), Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers, DataOption3:=xlSortTextAsNumbers 
Columns("A:A").Insert Shift:=xlToRight 
Range("A1").FormulaR1C1 = "" 
Range("A2").Select 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Copy Before:=Sheets(3) 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Move After:=Sheets(4) 
Sheets("Sheet4 (3)").Select 
Sheets("Sheet4 (3)").Name = "ChocoStrawb" 
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 
Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

Sheets("ChocoStrawb").Select 
Rows("2:4200").Select 
Range(Selection, Selection.End(xlDown)).Select 
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Clear 
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range(_ 
    "A2:A4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ 
    xlSortNormal 
ActiveWorkbook.Worksheets("ChocoStrawb").Sort.SortFields.Add Key:=Range(_ 
    "B2:B4200"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _ 
    xlSortTextAsNumbers 
With ActiveWorkbook.Worksheets("ChocoStrawb").Sort 
    .SetRange Range("A2:O4200") 
    .Header = xlGuess 
    .MatchCase = False 
    .Orientation = xlTopToBottom 
    .SortMethod = xlPinYin 
    .Apply 
End With 
Rows("1:1").Select 

' PlatinumPlus 
Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers 
Columns("A:A").Insert Shift:=xlToRight 
Range("A1").FormulaR1C1 = "" 
Range("A2").Select 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Copy Before:=Sheets(3) 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Move After:=Sheets(4) 
Sheets("Sheet4 (3)").Select 
Sheets("Sheet4 (3)").Name = "PlatPlus" 
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLATIN"",RC[3]=""AMBASS""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 
Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

' Platinum 
Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("D2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers 
Columns("A:A").Insert Shift:=xlToRight 
Range("A1").FormulaR1C1 = "" 
Range("A2").Select 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Copy Before:=Sheets(3) 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Move After:=Sheets(4) 
Sheets("Sheet4 (3)").Select 
Sheets("Sheet4 (3)").Name = "Platinum" 
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 
Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

' Gold 
Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("E2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortTextAsNumbers 
Range("C6").Select 
Range("C496:C4288").Select 
Range("C4288:C16").Select 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Copy Before:=Sheets(5) 
Sheets("Sheet4 (2)").Select 
Sheets("Sheet4 (2)").Name = "Gold" 
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""BRONZE"", RC[3]=""PLATIN"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
' Rajout 
Range("A2:A4200").Select 
Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 

' Silver 

Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Cells.Select 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Range("C13").Select 
Sheets("Platinum").Select 
Cells.Select 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Range("C7").Select 
Sheets("Gold").Select 
Sheets("Sheet4 (3)").Select 
Sheets("Sheet4 (3)").Name = "Silver" 
Sheets("Silver").Select 
Sheets("Silver").Copy Before:=Sheets(6) 
Sheets("Silver").Select 
ActiveCell.FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""PLATIN"", RC[3]=""BRONZE"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 

Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
Cells.Select 

' Bronze 

Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlDescending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Cells.Select 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 
Sheets("Silver (2)").Select 
Columns("B:D").Select 
Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal 
Range("A2").FormulaR1C1 = "=IF(OR(RC[1]=R[-1]C[1],RC[3]=""SILVER"", RC[3]=""PLATIN"", RC[3]=""GOLD"",RC[3]=""PLPLUS"",RC[3]=""AMBASS""),""Delete"", """")" 
Range("A2").AutoFill Destination:=Range("A2:A519"), Type:=xlFillDefault 
Range("A2:A519").AutoFill Destination:=Range("A2:A4200"), Type:=xlFillDefault 
Range("A2:A4200").Select 
Cells.Select 
Selection.Copy 
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 
Cells.Select 

Application.CutCopyMode = False 
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _ 
    , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortTextAsNumbers 

' Nomage C1 
Sheets("Champagne").Select 
Range("C1").Select 
Selection.Copy 
Sheets("Ambassador").Select 
Range("C1").Select 
ActiveSheet.Paste 
Sheets("PlatPlus").Select 
Range("D1").Select 
ActiveSheet.Paste 
Sheets("ChocoStrawb").Select 
Range("D1").Select 
ActiveSheet.Paste 
Sheets("Ambassador").Select 
Range("D1").Select 
ActiveSheet.Paste 
Sheets("Platinum").Select 
Range("C1").Select 
ActiveSheet.Paste 
Sheets("Gold").Select 
Range("C1").Select 
ActiveSheet.Paste 
Sheets("Silver").Select 
Range("C1").Select 
ActiveSheet.Paste 
Sheets("Silver (2)").Select 
Range("C1").Select 
ActiveSheet.Paste 

' Nomage Bronze 
Sheets("Silver (2)").Select 
Sheets("Silver (2)").Name = "Bronze" 
Range("A1").Select 

Sheets("Champagne").Select 
Range("A1").Select 
Application.CutCopyMode = False 
ActiveCell.FormulaR1C1 = "" 
Range("A1").Select 

' Filtre et Figer 
Sheets("Champagne").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Platinum").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("PlatPlus").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Columns("A:A").Select 
Selection.Delete Shift:=xlToLeft 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Silver").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Bronze").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Gold").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("ChocoStrawb").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Columns("A:A").Select 
Selection.Delete Shift:=xlToLeft 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Water").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Ambassador").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Columns("A:A").Select 
Selection.Delete Shift:=xlToLeft 
Range("C2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 
Sheets("Download").Select 
Cells.Select 
Cells.EntireColumn.AutoFit 
Range("A2").Select 
ActiveWindow.FreezePanes = True 
Rows("1:1").Select 
Selection.AutoFilter 

' Color 
Sheets("Champagne").Select 
ActiveWorkbook.Sheets("Champagne").Tab.ColorIndex = 6 
Sheets("Platinum").Select 
ActiveWorkbook.Sheets("Platinum").Tab.ColorIndex = 16 
Sheets("PlatPlus").Select 
ActiveWorkbook.Sheets("PlatPlus").Tab.ColorIndex = 55 
Sheets("Silver").Select 
ActiveWorkbook.Sheets("Silver").Tab.ColorIndex = 15 
Sheets("Bronze").Select 
ActiveWorkbook.Sheets("Bronze").Tab.ColorIndex = 9 
Sheets("Gold").Select 
ActiveWorkbook.Sheets("Gold").Tab.ColorIndex = 43 
Sheets("ChocoStrawb").Select 
ActiveWorkbook.Sheets("ChocoStrawb").Tab.ColorIndex = 3 
Sheets("Water").Select 
ActiveWorkbook.Sheets("Water").Tab.ColorIndex = 2 
Sheets("Ambassador").Select 
ActiveWorkbook.Sheets("Ambassador").Tab.ColorIndex = 1 
Sheets("Download").Select 
ActiveWorkbook.Sheets("Download").Tab.ColorIndex = 4 

' Delete 

Dim WS As Worksheet 

For Each WS In ActiveWorkbook.Worksheets 
For x = 4200 To 2 Step -1 
    If WS.Cells(x, 1).Value = "Delete" Then 
     WS.Rows(x).EntireRow.Delete 
    End If 
Next x 
Next WS 


' Formulas 

Sheets("Water").Select 
Cells.Select 
Range("A2").Select 
ActiveCell.Formula = "=SUM(D2:N2)+((COUNTIF(D2:N2,""GOLD"")+COUNTIF(D2:N2,""PLATIN""))*1)+((COUNTIF(D2:N2,""PLPLUS"")+COUNTIF(D2:N2,""AMBASS""))*2)" 
Range("A2").AutoFill Destination:=Range("A2:A" & Cells(Rows.Count, 2).End(xlUp).Row) 
LastRow = Range("A2").End(xlDown).Row 
Cells(LastRow + 2, "A").Formula = "=SUM(A2:A" & LastRow & ")" 
Dim LRowA As String, LRowB As String 
LRowA = [A4200].End(xlUp).Address 
Range("A:A").Interior.ColorIndex = xlNone 
Range("A2:" & LRowA).Interior.ColorIndex = 33 
Range("A:A").HorizontalAlignment = xlCenter 



' Classement Onglets 
Sheets("Water").Select 
Sheets("Water").Move Before:=Sheets(2) 
Sheets("ChocoStrawb").Select 
Sheets("ChocoStrawb").Move Before:=Sheets(3) 
Sheets("Bronze").Select 
Sheets("Bronze").Move Before:=Sheets(4) 
Sheets("Silver").Select 
Sheets("Silver").Move Before:=Sheets(5) 
Sheets("Gold").Select 
Sheets("Gold").Move Before:=Sheets(6) 
Sheets("Champagne").Select 
End Sub

Ce Mon code entier .. Maintenant sous « feuilles de chocolat et 'feuilles d'eau, je veux la même cabine sur la même ligne si elles sont valables pour la condition, même si elles sont de statut différent.

Source

2017-02-27 JohanEs

Il est très difficile de vous aider avec une seule ligne de votre code à regarder. (Surtout quand ce morceau de code fait référence à quelque chose 3 colonnes à la droite de l'ActiveCell qui, selon ce qu'ActiveCell était, signifierait dans la colonne D ou plus tard mais vos données semblent avoir l'information dans la colonne C.Veuillez coller le reste du code dans la question afin que nous puissions vous aider. – YowE3K

@ YowE3K, j'ai édité ma question Pouvez-vous jeter un oeil s'il vous plaît – JohanEs

Normalement, je considère qu'il est amusant d'accepter le défi de ranger votre code afin que je puisse le comprendre assez pour déterminer ce qui ne va pas, mais votre exigence de tout gérer dans un sous-programme (plutôt que de décomposer le code en plus petits morceaux pour qu'il soit plus facile à gérer) signifie que je ne vais même pas y penser. – YowE3K

en supposant vos données sont:

dans la feuille du nom "mySheetName"
dans les colonnes de a à D
avec la première ligne comme "tête" un
avec tous les enregistrements qui partagent le même « code » dans une plage contiguës

vous pouvez ensuite utiliser:

Option Explicit 

Sub main() 
    Dim code As Variant 

    With Sheets("mySheetName") '<--| change "mySheetName" to your actual sheet name 
     With .Range("D1", .cells(.Rows.Count, "A").End(xlUp)) '<--| reference its columns A:D range from row 1 (header) down to the one corresponding to last column A not empty row 
      DeleteSilverAndBronzeRecords .cells '<--| delete all records with "SILVER" or "BRONZE" in columnn "C" 
      For Each code In GetCodes(.Resize(.Rows.Count - 1, 1).Offset(1)) '<-- loop through unique "codes" starting from 2nd row downwards 
       If Application.WorksheetFunction.CountIf(.cells, code) > 1 Then HandleCodes .cells, code '<--| if more then one current 'code' occurrences then "handle" it 
      Next 
     End With 
    End With 
End Sub 


Sub DeleteSilverAndBronzeRecords(rng As Range) 
    With rng 
     .AutoFilter Field:=3, Criteria1:=Array("GOLD", "SILVER", "BRONZE"), Operator:=xlFilterValues '<--| filter column C cells with "GOLD", "SILVER" or "BRONZE" 
     If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any filtered cell other than headers 
      Application.DisplayAlerts = False 
      .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible).Delete '<-- delete filtered cells, skipping headers 
      Application.DisplayAlerts = True 
     End If 
     .Parent.AutoFilterMode = False 
    End With 
End Sub 

Sub HandleCodes(rng As Range, code As Variant) 
    Dim cell As Range 
    Dim iCell As Long, refvalue As Long 
    Dim strng As String 

    With rng 
     .AutoFilter Field:=1, Criteria1:=code '<--| filter column A cells with current 'code' 
     If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then 
      With .Resize(.Rows.Count - 1, 1).Offset(1).SpecialCells(xlCellTypeVisible) '<-- reference filtered cells, skipping headers 
       For Each cell In .cells '<--| loop through filtered cells 
        strng = strng & Join(Application.Transpose(Application.Transpose(cell.Offset(, 1).Resize(, 2).Value)), " ") & " " '<--| build concatenated string from all current 'code' records 
       Next 
       .cells(1, 2).Value = WorksheetFunction.Trim(strng) '<--| write updated column "B" content in first record with current "code" 
       Application.DisplayAlerts = False 
       .Resize(.Rows.Count - 1).Offset(1).Delete '<--| delete all current "code" occurrences from the 2nd one on 
       Application.DisplayAlerts = True 
      End With 
     End If 
     .Parent.AutoFilterMode = False 
    End With 
End Sub 

Function GetCodes(rng As Range) As Variant 
    Dim cell As Range 
    With CreateObject("Scripting.Dictionary") 
     For Each cell In rng 
      .Item(cell.Value) = cell.Value 
     Next cell 
     GetCodes = .keys 
    End With 
End Function

Source

2017-02-27 10:24:26 user3598756

Essayez le code édité – user3598756

@JohanEs, avez-vous passé à travers elle? – user3598756

Pouvez-vous s'il vous plaît regarder à nouveau ... J'ai édité ma question ... – JohanEs

Dans Excel --- Accueil --- Mise en forme conditionnelle --- règles de cellules ---- valeurs en double point fort --- (Sélectionnez votre gamme et faire) Faites-moi savoir si vous avez besoin de plus

Source

2017-02-27 01:55:50

Cela ne va-t-il pas simplement mettre en évidence les doublons? – YowE3K

Il mettra en évidence le test maintenant et basé sur la couleur juste trier –

Il est très difficile de trier plusieurs lignes dans une seule rangée. (Ce que je ** pense ** est ce que le PO essaye de faire - mais ils n'ont pas vraiment dit quel problème ils ont - je ne suis pas sûr si le deuxième ensemble de données dans la question est "désiré" ou "courant" de sortie qui ne correspond pas "désiré" d'une certaine manière.) – YowE3K

Comment aligner les doublons sur les mêmes lignes dans Excel en VBA

Répondre

Questions connexes