使用VBA搜索Excel并导出某些数据

Question

So I have now changed the macro below to this and am getting a

Runtime 1004 error at

ActiveSheet.Name = ShipperName

Code:

Sub CopyShipperToNewSheet()

Dim LR As Long
Dim ShipperName As String

' Last row of your data
LR = Range("A" & Cells.Rows.Count).End(xlUp).Row

' Loop Name range ( Column U)
For i = 2 To Range("U" & Cells.Rows.Count).End(xlUp).Row
    ShipperName = Cells(i, 21)

    ' Use filter
    Cells.Select
    Selection.AutoFilter

    ' field =4 (column D----Shippers Name)
    ActiveSheet.Range("$A$1:$S$" & LR).AutoFilter Field:=4, Criteria1:=ShipperName

    ' Copy visible cell
    [A1].CurrentRegion.Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy

    ' Paste to new sheet
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Name = ShipperName

    ' Go back sheet1
    Sheets("Sheet1").Select
    Selection.AutoFilter
Next i
End Sub

Answer 1

First get unique shipper name

The screenshot：

You can change this macro for yourself:

Sub CopyShipperToNewSheet()

Dim LR As Long
Dim ShipperName As String

' Last row of your data
LR = Range("A" & Cells.Rows.Count).End(xlUp).Row

' Loop Name range ( Column F)
For i = 2 To Range("F" & Cells.Rows.Count).End(xlUp).Row
    ShipperName = Cells(i, 6)

    ' Use filter
    Cells.Select
    Selection.AutoFilter

    ' field =4 (column D----Name)
    ActiveSheet.Range("$A$1:$D$" & LR).AutoFilter Field:=4, Criteria1:=ShipperName

    ' Copy visible cell
    [A1].CurrentRegion.Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy

    ' Paste to new sheet
    Sheets.Add After:=ActiveSheet
    Selection.PasteSpecial Paste:=xlPasteValues
    ActiveSheet.Name = ShipperName

    ' Go back sheet1
    Sheets("Sheet1").Select
    Selection.AutoFilter
Next i
End Sub

Hope this will help you.