Vba Excel宏，根据'；类别'；柱

我有我认为是一个相当简单的要求，但我有困难实现。我曾尝试过复制和修改我研究过的各种vba代码，但似乎都不适合我

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

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

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

我真希望有人能帮助我

谢谢

---

Paul

假设“主”工作表中有3列：名称|地址|类别，此标题将复制到名为工作表的类别中

然后，

PopulateMasterContacts

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

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

Private Const sMasterSheet As String=“Master”主控表名称
当长度=1'库曼A时，专用常量lNameCol
Private Const lAddrCol长度=2'列B
“专用Const lCateCol As Long=3”列C
专用Const lCateCol，长度=16'列P
将oShM标注为主工作表的“工作表”
子种群主联系人（）
常量lRowStart的长度=2
暗淡的lRowM和长的一样，lRowLast和长的一样
Application.ScreenUpdating=False
设置oShM=此工作簿。工作表（sMasterSheet）
lRowLast=oShM.Cells.SpecialCells（xlLastCell.Row）
对于lRowM=lRowStart到lRowLast
Application.StatusBar=“处理行”&lRowM
如果不是空的（oShM.细胞（lRowM，lNameCol）），则
ProcessContact lRowM
如果结束
下一个
分拣单
设置oShM=无
Application.StatusBar=False
Application.ScreenUpdating=True
端接头
私人子分拣表（）
将oSh设置为工作表
针对本工作簿中的每个职业安全与健康。工作表
如果是职业安全与健康管理局名称，请填写明细表
oSh.UsedRange.Sort Key1:=oSh.Cells（2，lNameCol），标题：=xlYes
如果结束
下一个
端接头
专用子进程联系人（lR尽可能长）
将散页变暗为字符串，将下一行变长，将oSh变为工作表
sCategory=oShM.单元（lR，lCateCol）.值
如果Len（sCategory）>0，则
设置oSh=获取工作表（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）
设置oSh=无
如果结束
端接头
私有函数GetWorksheet（sName作为字符串）作为工作表
出错时继续下一步
将oSh设置为工作表
设置oSh=此工作簿。工作表（sName）
如果oSh算不了什么
设置oSh=ThisWorkbook.Worksheets.Add（后面：=oShM）
oSh.Name=sName
oShM.Rows（1）.复制目标：=oSh.Rows（1）'复制头
如果结束
设置GetWorksheet=oSh
端函数

更新的屏幕截图：

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

---

您尝试过什么（提供您的代码）？你有错误吗？如果是这样，错误消息是什么？它在哪一行出错？如果它没有出错，代码会产生什么结果？这与预期的结果有什么不同？Patrick-这很有效。我的实际工作表包含更多的列，所以我试图修改您的脚本，但得到了下标脱线错误。我做了一些进一步的尝试，发现只要类别col是col 3，它就可以工作，但我的类别实际上是col P。我尝试在这个评论中发布我的代码，但它太长了。我已经修改了代码，将P列用作类别列。再来一次。您需要更改的常量是

lCateCol

。您好-我现在收到一个运行时错误9-下标超出范围错误。正在尝试调试哪一行，以查看这在哪一行上导致了问题，但运气不太好。@我猜您指的是头2行标题：change

oShM.rows（1）。Copy Destination:=oSh.rows（1）'将标题复制到
oShM.rows（“1:2”）。Copy Destination:=oSh.rows（1）'将标题
和
Const lRowStart作为Long=2
复制到
Const lRowStart作为Long=3
。