vba - 自动排序和格式化以及 Excel

Question

我在 Excel 中有一个客户表，我希望能够将新客户添加到表格的最后一行，并且 Excel 会自动对表格进行排序，以便客户的名称按字母顺序排序。

此外，格式将类似于上一行。比如第二列是DOB，所以我希望格式和上一行MM/DD/YYYY一样

谢谢

Answer 1

将附加的代码放入您的工作表模块中，它会自动对您的 A 列进行排序。

Private Sub Worksheet_Change(ByVal Target As Range)
'turn off updates to speed up code execution
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

If Not Intersect(Target, Columns(1)) Is Nothing Then

    With ActiveSheet.Sort
        .SetRange Range("A1:X" & Cells(Rows.Count, 1).End(xlUp).Row)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Columns("B").NumberFormat = "MM/DD/YYYY"

End If

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


End Sub

Answer 2

这是一段 VBA，一旦输入最后一行的第一个单元格，它就会自动添加您的表格。您必须提供 IsChangeInLastLineOfStrRange 函数并从更改事件中调用 AddEmptyRowWhenFull。它可能需要调整，因为我从中删除了一些代码。原来有一个递归计时器来防止......好吧......递归。

Public Sub AddEmptyRowWhenFull(SheetName As String, Area As String, Target As Range)
    Dim rngDatabase As Range

    With Sheets(SheetName)
        If IsChangeInLastLineOfStrRange(SheetName, Area, Target) _
        And Target.Value <> "" Then
            Set rngDatabase = .Range(Area)
            AddEmptyRow rngDatabase, rngDatabase.Rows.Count
        End If
    End With
End Sub


Public Sub AddEmptyRow(Database As Range, RowPosition As Long, Optional ClearLine As Boolean = True)
    Dim bScreenupdate, iCalculation As Integer
    Dim colnum As Long, markrow As Long
    Dim bUpdate As Boolean

    bScreenupdate = Application.ScreenUpdating
    iCalculation = Application.Calculation

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With Database
         If RowPosition < .Rows.Count Then
            .Rows(RowPosition - 0).Copy                     'Insert in and after data
        .Rows(RowPosition + 1).Insert shift:=xlDown
         Else
            .Rows(RowPosition - 0).Copy                     'Add line at end by inserting before last line
            .Rows(RowPosition - 0).Insert shift:=xlDown     ' to prevent cell formatting below it to be copied too
             RowPosition = RowPosition + 1                  'Clear last of the copies
         End If

         If ClearLine = False Then                          'Move cursor down
            ActiveSheet.Cells(ActiveCell.row + 1, ActiveCell.column).Activate
         Else
            For colnum = 1 To .Columns.Count                'Preserve formula's
                If Not .Rows(RowPosition).Cells(1, colnum).HasFormula Then 'changed
                       .Rows(RowPosition).Cells(1, colnum).ClearContents
                End If
            Next colnum
         End If

         'Fix rowheight if we shift into other heights

         .Rows(RowPosition + 1).RowHeight = .Rows(RowPosition + 0).RowHeight
    End With

    If bScreenupdate = True Then Application.ScreenUpdating = True
    If Not iCalculation = xlCalculationManual Then Application.Calculation = iCalculation
End Sub

阿让。