Vba 自动排序、格式化和Excel_Vba_Excel_Ms Office_Spreadsheet

Vba 自动排序、格式化和Excel

vba excel ms-office

Vba 自动排序、格式化和Excel,vba,excel,ms-office,spreadsheet,Vba,Excel,Ms Office,Spreadsheet,我在Excel中有一个客户表，我希望能够将新客户添加到表的最后一行，Excel将自动对表进行排序，以便客户的名称按字母顺序排序此外，格式将与前一行类似。例如，第二列是DOB，因此我希望格式与前一行MM/DD/YYYY相同谢谢将所附代码放入工作表模块，它将自动对列A排序 Private Sub Worksheet_Change(ByVal Target As Range) 'turn off updates to speed up code execution With Application

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

此外，格式将与前一行类似。例如，第二列是DOB，因此我希望格式与前一行MM/DD/YYYY相同

谢谢

将所附代码放入工作表模块，它将自动对列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

将附加的代码放入工作表模块，它将自动对列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

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

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

Public Sub addemptyrowhenfull（SheetName作为字符串，Area作为字符串，Target作为范围）
Dim rngDatabase As范围
带图纸（图纸名称）
如果更改了STLLINOFSTRANGE（图纸名称、面积、目标）_
和Target.Value“”，则
设置rngDatabase=.Range（区域）
AddEmptyRow rngDatabase，rngDatabase.Rows.Count
如果结束
以
端接头
Public Sub AddEmptyRow（数据库作为范围，行位置作为长度，可选的ClearLine作为布尔值=True）
Dim B屏幕更新，iCalculation为整数
Dim colnum尽可能长，markrow尽可能长
Dim bUpdate作为布尔值
bScreenupdate=Application.screenUpdate
iCalculation=应用程序计算
Application.ScreenUpdating=False
Application.Calculation=xlCalculationManual
使用数据库
如果RowPosition<.Rows.Count，则
.Rows（RowPosition-0）.复制“在数据中和之后插入”
.行（行位置+1）。插入移位：=xlDown
其他的
.Rows（RowPosition-0）。复制“通过在最后一行之前插入在末尾添加行”
.Rows（RowPosition-0）。插入shift:=xlDown'以防止其下方的单元格格式也被复制
RowPosition=RowPosition+1'清除最后一份副本
如果结束
如果ClearLine=False，则“向下移动光标”
单元格（ActiveCell.row+1，ActiveCell.column）。激活
其他的
对于colnum=1到.Columns.Count的“保留公式”
如果不是，则.Rows（RowPosition）.Cells（1，colnum）.HasFormula然后“更改”
.Rows（RowPosition）.Cells（1，colnum）.ClearContents
如果结束
下一个秋千
如果结束
“如果我们换到其他高度，请固定划船高度
.Rows（RowPosition+1）。RowHeight=.Rows（RowPosition+0）。RowHeight
以
如果bScreenupdate=True，则Application.screenUpdate=True
如果不是iCalculation=xlCalculationManual，则Application.Calculation=iCalculation
端接头

Arjen.

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

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

Public Sub addemptyrowhenfull（SheetName作为字符串，Area作为字符串，Target作为范围）
Dim rngDatabase As范围
带图纸（图纸名称）
如果更改了STLLINOFSTRANGE（图纸名称、面积、目标）_
和Target.Value“”，则
设置rngDatabase=.Range（区域）
AddEmptyRow rngDatabase，rngDatabase.Rows.Count
如果结束
以
端接头
Public Sub AddEmptyRow（数据库作为范围，行位置作为长度，可选的ClearLine作为布尔值=True）
Dim B屏幕更新，iCalculation为整数
Dim colnum尽可能长，markrow尽可能长
Dim bUpdate作为布尔值
bScreenupdate=Application.screenUpdate
iCalculation=应用程序计算
Application.ScreenUpdating=False
Application.Calculation=xlCalculationManual
使用数据库
如果RowPosition<.Rows.Count，则
.Rows（RowPosition-0）.复制“在数据中和之后插入”
.行（行位置+1）。插入移位：=xlDown
其他的
.Rows（RowPosition-0）。复制“通过在最后一行之前插入在末尾添加行”
.Rows（RowPosition-0）。插入shift:=xlDown'以防止其下方的单元格格式也被复制
RowPosition=RowPosition+1'清除最后一份副本
如果结束
如果ClearLine=False，则“向下移动光标”
单元格（ActiveCell.row+1，ActiveCell.column）。激活
其他的
对于colnum=1到.Columns.Count的“保留公式”
如果不是，则.Rows（RowPosition）.Cells（1，colnum）.HasFormula然后“更改”
.Rows（RowPosition）.Cells（1，colnum）.ClearContents
如果结束
下一个秋千
如果结束
“如果我们换到其他高度，请固定划船高度
.Rows（RowPosition+1）。RowHeight=.Rows（RowPosition+0）。RowHeight
以
如果bScreenupdate=True，则Application.screenUpdate=True
如果不是iCalculation=xlCalculationManual，则Application.Calculation=iCalculation
端接头

Arjen.

Re:AutoSort

->为此，您需要一些VBA。Excel不会只是排序，除非你告诉它-或编程

Re:Formatting

->您可以对任意数量的单元格进行预格式化，即使它们没有填充。只需选择您想要的范围和格式。@ScottHoltzman好的，我如何使用VBA？在VBA中找不到正确的解决方案。请使用

工作表