0

我有一个我认为相当简单的要求，但在实施时遇到了麻烦。我曾尝试复制和修改我研究过的各种 vba 代码，但似乎没有一个对我有用。

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

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

我想运行一个创建或附加到名为伦敦、曼彻斯特和利物浦的工作表的 marco，并将相应的行复制到相关工作表并按字母顺序排序。

我希望有人能帮助我。

谢谢

保罗

4

1 回答 1

1

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

然后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

更新截图： 在此处输入图像描述

当状态栏中出现错误时，它会显示哪一行？ 在此处输入图像描述

于 2013-08-22T03:31:31.457 回答