Excel宏根据＆＃39;类别＆＃39;的值将整行复制到新工作表。柱

Question

我认为这是一个相当简单的要求，但实施起来很困难。我试过复制和修改我研究过的各种vba代码，但似乎没有一个对我有用。

我有一个电子表格，基本上是一个名称和地址列表。我有一个名为category的列，我希望能够使用它来填充新的（如果它们不存在，并且如果它们存在则附加）工作表。

想象一下，我有4个客户 - 其中两个是伦敦，1个是曼彻斯特，1个是利物浦。这些都在“主”工作表中。

我想运行一个创建或附加到名为London，Manchester和Liverpool的工作表的marco，并将相应的行复制到相关的工作表并按字母顺序排序。

我希望有人可以帮助我。

感谢

保

Answer 1

假设您在“主”工作表中有3列：名称|地址|类别和此标题将被复制到类别命名表。

然后PopulateMasterContacts将处理Master中的行并放入名为Category的工作表中。如果找不到此命名的工作表，它将创建一个并复制标题，然后复制联系人详细信息。并排除除Master之外的所有工作表。请注意，这不会删除重复项。

Private Const sMasterSheet As String = "Master" ' Master Sheet Name

Private Const lNameCol As Long = 1 ' Coulmn A
Private Const lAddrCol As Long = 2 ' Column B
'Private Const lCateCol As Long = 3 ' Column C
Private Const lCateCol As Long = 16 ' Column P

Dim oShM As Worksheet ' For Master Worksheet

Sub PopulateMasterContacts()
    Const lRowStart As Long = 2
    Dim lRowM As Long, lRowLast As Long

    Application.ScreenUpdating = False
    Set oShM = ThisWorkbook.Worksheets(sMasterSheet)
    lRowLast = oShM.Cells.SpecialCells(xlLastCell).Row
    For lRowM = lRowStart To lRowLast
        Application.StatusBar = "Processing row " & lRowM
        If Not IsEmpty(oShM.Cells(lRowM, lNameCol)) Then
            ProcessContact lRowM
        End If
    Next
    SortSheets
    Set oShM = Nothing
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Private Sub SortSheets()
    Dim oSh As Worksheet
    For Each oSh In ThisWorkbook.Worksheets
        If oSh.Name <> sMasterSheet Then
            oSh.UsedRange.Sort Key1:=oSh.Cells(2, lNameCol), Header:=xlYes
        End If
    Next
End Sub

Private Sub ProcessContact(lR As Long)
    Dim sCategory As String, lRowNext As Long, oSh As Worksheet
    sCategory = oShM.Cells(lR, lCateCol).Value
    If Len(sCategory) > 0 Then
        Set oSh = GetWorksheet(sCategory)
        lRowNext = oSh.Cells.SpecialCells(xlLastCell).Row + 1
        lRowNext = oSh.Cells(lRowNext, lNameCol).End(xlUp).Row + 1
        oShM.Rows(lR).Copy Destination:=oSh.Rows(lRowNext)
        Set oSh = Nothing
    End If
End Sub

Private Function GetWorksheet(sName As String) As Worksheet
    On Error Resume Next
    Dim oSh As Worksheet
    Set oSh = ThisWorkbook.Worksheets(sName)
    If oSh Is Nothing Then
        Set oSh = ThisWorkbook.Worksheets.Add(after:=oShM)
        oSh.Name = sName
        oShM.Rows(1).Copy Destination:=oSh.Rows(1) ' Copy header
    End If
    Set GetWorksheet = oSh
End Function

更新截图：

状态栏中出现错误时显示哪一行？