组合重复列

Question

我正在尝试编写一个excel宏来组合电子表格中的列 具体来说，有七列，每列都有唯一的标题，无限重复。

我想将具有相同标题的所有列合并为一个，只留下七列包含所有数据。我不想连接列，而是将每个新列的数据添加到底部的前一列。

正如你在下面的代码中看到的那样，我已经用我记录的宏和我在网上找到的宏，以及我自己的一些代码在这里和那里进行了frankensteined。这是非常不善言辞和冗长的，我确信这是一个更容易的解决方案。

Sub Pop()
'
' Pop Macro
'
Dim i As Integer
Dim ws As Worksheet
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Dim iSheetCount

    Application.ScreenUpdating = False
    'Format
    Application.ScreenUpdating = False
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=R[1]C"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=IF(OR(R[1]C=R[1]C[-1]),"""",R[1]C)"
    Range("B1").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2]),"""",R[1]C)"
    Range("C1").Select
    Selection.Copy
    Range("D1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3]),"""",R[1]C)"
    Range("D1").Select
    Selection.Copy
    Range("E1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4]),"""",R[1]C)"
    Range("E1").Select
    Selection.Copy
    Range("F1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=B2F2=R[1]C[-5]),"""",R[1]C)"
    Range("F1").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5]),"""",R[1]C)"
    Range("F1").Select
    Selection.Copy
    Range("G1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=B2G2=R[1]C[-6]),"""",R[1]C)"
    Range("G1").Select
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6]),"""",R[1]C)"
    Range("G1").Select
    Selection.Copy
    Range("H1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6],R[1]C=R[1]C[-7]),"""",R[1]C)"
    Range("H1").Select
    Selection.Copy
    Range("I1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6],R[1]C=R[1]C[-7],R[1]C=R[1]C[-8]),"""",R[1]C)"
    Range("I1").Select
    Selection.Copy
    Range("J1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = _
        "=IF(OR(R[1]C=R[1]C[-1],R[1]C=R[1]C[-2],R[1]C=R[1]C[-3],R[1]C=R[1]C[-4],R[1]C=R[1]C[-5],R[1]C=R[1]C[-6],R[1]C=R[1]C[-7],R[1]C=R[1]C[-8],R[1]C=R[1]C[-9]),"""",R[1]C)"
    Rows("1:1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False

    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets.Add
    Sheets("Sheet2").Select
    Sheets.Add
    Sheets("Sheet3").Select
    Sheets.Add
    Sheets("Sheet4").Select
    Sheets.Add
    Sheets("Sheet5").Select
    Sheets.Add
    Sheets("Sheet6").Select
    Sheets.Add
    Sheets("Sheet7").Select
    Sheets.Add
    Sheets("Sheet8").Select
    Sheets.Add
    Sheets("Sheet9").Select
    Sheets.Add
    Sheets("Sheet10").Select
    Sheets.Add
    Sheets("Sheet11").Select
    Sheets("Sheet11").Name = "Legend"
    ActiveSheet.Paste
    ActiveWindow.SmallScroll ToRight:=-4
    ActiveWindow.ScrollWorkbookTabs Sheets:=-1
    ActiveWindow.ScrollWorkbookTabs Sheets:=-1
    Sheets("Sheet1").Select
    Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Sheets("Sheet2").Select
    'Format Sheet 2
    Sheets("Sheet2").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C1,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 3
    Sheets("Sheet3").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C2,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
     'Format Sheet 4
     Sheets("Sheet4").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C3,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 5
    Sheets("Sheet5").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C4,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 6
    Sheets("Sheet6").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C5,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 7
    Sheets("Sheet7").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C6,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 8
    Sheets("Sheet8").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C7,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 9
    Sheets("Sheet9").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C8,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    'Format Sheet 10
    Sheets("Sheet10").Select
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "=IF(Sheet1!R1C=Legend!R1C9,Sheet1!RC,""P"")"
    Range("A1").Select
    Selection.AutoFill Destination:=Range("A1:A500"), Type:=xlFillDefault
    Range("A1:A500").Select
    Selection.AutoFill Destination:=Range("A1:ZZ500"), Type:=xlFillDefault
    Range("A1:ZZ500").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Application.CutCopyMode = False
    Selection.Replace what:="P", Replacement:="", lookat:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
    ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A1:ZZ1") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.ActiveSheet.Sort
        .SetRange Range("A1:ZZ500")
        .header = xlNo
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With

    'Cycle
    For i = 2 To 10
    mysheet = "Sheet" & i
    Sheets(mysheet).Select
    On Error GoTo Error_Handler
    'CollapseColumns
    Set ws_from = ActiveWorkbook.ActiveSheet
    Rows("1:1").Select
    Selection.Delete Shift:=xlUp
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column

'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0

'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"

For from_colndx = 1 To from_lastcol
    from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
    'If you're going to exceed 65536 rows
    If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
        to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
    Else
        GoTo Error_Handler
    End If
    ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
      from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
        For iSheetCount = 1 To Sheets.Count
        Sheets(iSheetCount).Name = iSheetCount
    Next iSheetCount

' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Next i
Error_Handler:
    Sheets("Sheet2").Delete
    Sheets("Sheet3").Delete
    Sheets("Sheet4").Delete
    Sheets("Sheet5").Delete
    Sheets("Sheet6").Delete
    Sheets("Sheet7").Delete
    Sheets("Sheet8").Delete
    Sheets("Sheet9").Delete
    Sheets("Sheet10").Delete
    Sheets("AllData").Delete

Application.ScreenUpdating = True

End Sub

Answer 1

首先，您应该始终避免使用Select，Selection和＆amp;正如here所解释的ActiveCell。宏录制器是一个很好的起点，所以很好的工作让宏工作！

我相信以下代码无需添加和删除工作表即可完成您想要的工作：

Option Explicit

Sub Test()

Dim ws              As Worksheet
Dim FirstLastRow    As Long
Dim curLastRow      As Long
Dim LastColumn      As Long
Dim i As Long, j As Long

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Worksheets("Sheet1")
LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column

For i = 1 To LastColumn
    FirstLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
    For j = LastColumn To i + 1 Step -1
        If ws.Cells(1, j).Value = ws.Cells(1, i).Value And i <> j Then
            curLastRow = ws.Cells(Rows.Count, j).End(xlUp).Row
            ws.Range(ws.Cells(2, j), ws.Cells(curLastRow, j)).Copy ws.Cells(FirstLastRow + 1, i)
            ws.Columns(j).Delete Shift:=xlToLeft
            FirstLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
        End If
    Next j
    LastColumn = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Next i

For i = 1 To LastColumn
curLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row
With ws.Sort
    .SortFields.Clear
    .SortFields.Add Key:=ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i))
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
Next i

Application.ScreenUpdating = True

End Sub

备注：

1. 如果"Sheet1"发生变化，您需要将Option Explicit替换为正确的工作表参考。
顶部的
2. Variant强制您在使用之前对每个变量进行尺寸标注。这有助于消除将来出现的问题，因为所有未标注的变量都会被Excel自动标注为LastColumn。

修改

以下是专门针对您的工作簿（http://imgur.com/hGCoWHt）量身定制的不同变体，不依赖于Option Explicit Sub Test2() Dim ws As Worksheet Dim FirstLastRow As Long Dim curLastRow As Long Dim i As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Sheet1") Do Until ws.Cells(1, 8).Value = "" For i = 7 To 1 Step -1 FirstLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row curLastRow = ws.Cells(Rows.Count, i + 7).End(xlUp).Row ws.Range(ws.Cells(2, i + 7), ws.Cells(curLastRow, i + 7)).Copy ws.Cells(FirstLastRow + 1, i) ws.Columns(i + 7).Delete Next i Loop For i = 1 To 7 curLastRow = ws.Cells(Rows.Count, i).End(xlUp).Row With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal .SetRange ws.Range(ws.Cells(2, i), ws.Cells(curLastRow, i)) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With Next i Application.ScreenUpdating = True End Sub ：

{{1}}