如何在VBA中对齐Excel中相同行上的重复项答案

【问题标题】：How to align duplicates on the same rows in Excel in VBA如何在VBA中对齐Excel中相同行上的重复项
【发布时间】：2017-02-27 01:12:32
【问题描述】：

这是我的情况..

我有这个文件：

   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

在 A 列中：机舱号

B 列：先生或夫人

C 列：名字和姓氏

D 列：状态（青铜、白银等...）

E栏：会员编号

如果 A 列相同，我希望它位于同一行。但不包括青铜、白银、黄金、所以我把它放在我的 VBA 中以排除那些：

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

当我运行宏时，它给了我这个：

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

看看数字 1010..

不知何故，两者都处于这种状态，但由于它们具有不同的状态，宏将它们放在不同的行中，我不希望这样，我希望它们在同一行中..

你能帮帮我吗..

添加于 3 月 7 日，这是我的整个宏（我不想要另一个子）：

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

这是我的完整代码.. 现在在“巧克力床单”和“水床单”下，如果它们对条件有效，即使它们是不同的状态，我也希望在同一排的同一个客舱。

【问题讨论】：

只看一行代码很难帮助您。（特别是当那段代码引用 ActiveCell 右侧的 3 列时，这取决于 ActiveCell 是什么，在 D 列或更高版本中表示，但您的数据似乎在 C 列中有信息。）请粘贴将其余代码放入问题中，以便我们为您提供帮助。
@YowE3K，我编辑了我的问题，你能看看吗
通常我会认为接受挑战来整理你的代码是很有趣的，这样我就可以理解它以找出问题所在，但是你需要在一个子例程中处理所有事情（而不是打破将代码分成更小的块以便更容易管理）意味着我什至不会考虑这个。

标签： vba excel formulas

【解决方案1】：

假设您的数据是：

在以“mySheetName”命名的工作表中
在从 A 到 D 的列中
第一行作为“标题”
所有记录在连续范围内共享相同的“代码”

那么你可以使用：

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

【讨论】：

@JohanEs，你通过了吗？
在收到原始的解决方案后更改问题会导致所谓的“变色龙”问题，这里不允许。请花点时间对原始问题后收到的答案给予适当的反馈，如果他们解决了问题，请接受他们或说明他们没有解决的原因。此阶段结束后，您可能想提出其他问题或发布新问题
@user33598756 对编辑感到抱歉。我这样做是因为你的回答没有出现在我的宏上。这就是我编辑问题的原因，因为你的回答可能是正确的。但事实并非如此适合我的宏...这就是为什么我回过头来告诉您我编辑了我的问题，以便您可以查看您的答案...因为您的答案在我的微信中不起作用，所以它说错误...再次对误解表示抱歉...
您为什么不按照 cmets 的指导在这几部分中调整我的代码并自行运行？
DeleteSilverAndBronze 例如它不接受它...我对宏一无所知..我没有接受任何诅咒这是我第一次看到宏但我需要做它是为了我的工作....

【解决方案2】：

在 excel 中---主页---条件格式---突出显示单元格规则---重复值---（选择您的范围并执行）如果您需要更多信息，请告诉我

【讨论】：

不会突出显示重复项吗？
它现在会突出显示测试并根据颜色排序
很难将多行排序为一行。（我认为是 OP 正在尝试做的事情 - 但他们并没有真正说出他们遇到了什么问题 - 我不确定问题中的第二组数据是否“需要“输出或“当前”输出在某些方面与“期望”不匹配。）