常用代码归集

changur

！！！！！如果能写个扩展库，如jquery对js一样，那将是一件很厉害的事！！！！！！

jsgj2023

Sub 添加辅助列排序()
Dim ws As Worksheet
Dim myrange As Range
Dim mycolumn As Long
Dim myrow As Long
Set ws = Worksheets(1)
With ws
    .Select
    With .Range("a1").CurrentRegion
        mycolumn = .Columns.Count
        myrow = .Rows.Count
    End With
    .Columns(mycolumn + 1).Insert
    With .Cells(1, mycolumn + 1)
        .Value = 1
        .AutoFill Destination:=.Resize(myrow), Type:=xlFillSeries
    End With
    Set myrange = .Range("a1").CurrentRegion
    With myrange
        MsgBox "按姓名排序"
        .Sort key1:="姓名", order1:=xlAscending, Header:=xlYes
        MsgBox "恢复原状"
        .Sort key1:=.Cells(2, .Columns.Count), order1:=xlAscending, Header:=xlYes
    End With
    .Columns(mycolumn + 1).Delete
End With
Set myrange = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub 按单元格颜色排序()
Dim ws As Worksheet
Dim myrnage As Range
Dim myrow As Long
Dim mycolumn As Long
Dim i As Long
Set ws = Worksheets(1)
With ws
    With .Range("a1").CurrentRegion
        mycolumn = .Columns.Count
        myrow = .Rows.Count
    End With
    .Columns(mycolumn + 1).Insert
    For i = 2 To myrow
        .Cells(i, mycolumn + 1).Value = .Cells(i, 1).Interior.ColorIndex
    Next
    Set myRange = .Range("a1").CurrentRegion
    With myRange
        .Sort key1:=.Cells(1, mycolumn + 1), order1:=xlAscending, Header:=xlYes
    End With
    .Columns(mycolumn + 1).Delete
End With
Set myRange = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub 按字符长度排序()
Dim ws As Worksheet
Dim myrange As Range
Dim myrow As Long
Dim mycolumn As Long
Dim i As Long
Set ws = Worksheets(1)
With ws
    With .Range("a1").CurrentRegion
        mycolumn = .Columns.Count
        myrow = .Rows.Count
    End With
    .Columns(mycolumn + 1).Insert
    For i = 2 To myrow
        .Cells(i, mycolumn + 1).Value = Len(.Cells(i, 1).Value)
    Next
    Set myrange = .Range("a1").CurrentRegion
    With myrange
        .Sort key1:=.Cells(1, mycolumn + 1), order1:=xlAscending, Header:=xlYes
    End With
    .Columns(mycolumn + 1).Delete
End With
Set myrange = Nothing
Set ws = Nothing
End Sub

jsgj2023

Sub 按单元格字符串中的数字升序排列()
Dim ws As Worksheet
Dim myrange As Range
Dim myrow As Long
Dim mycolumn As Long
Dim i  As Long
Set ws = Worksheets(1)
With ws
    With .Range("a1").CurrentRegion
        mycolumn = .Columns.Count
        myrow = .Rows.Count
    End With
    .Columns(mycolumn + 1).Insert
    For i = 2 To myrow
        .Cells(i, mycolumn + 1).Value = findnumber(.Cells(i, 1).Text)
    Next i
    Set myrange = .Range("a1").CurrentRegion
    With myrange
        .Sort key1:=.Cells(1, mycolumn + 1), order1:=xlAscending, key2:=.Cells(1, 1), order2:=xlAscending, Header:=xlYes
    End With
    .Columns(mycolumn + 1).Delete
End With
Set myrange = Nothing
Set ws = Nothing
End Sub

Function findnumber(mystring As String)
Dim i As Integer
Dim j  As Integer
Dim mynum As String
For i = 1 To Len(mystring)
    If IsNumeric(Mid(mystring, i, 1)) Then
        j = j + 1
        mynum = mynum & Mid(mystring, i, 1)
    End If
    If j = 1 Then mynum = CInt(Mid(mystring, i, 1))
Next i
findnumber = CLng(mynum)
End Function

jsgj2023

Sub 取消指定单元格的合并区域()
With Range("a3")
    If .MergeCells = True Then
        .MergeArea.UnMerge
    Else
        MsgBox "没有合并的区域!"
    End If
End With
End Sub

jsgj2023

Sub 复制和移动单元格区域并对值累加()
    With Sheets("Sheet1")
        .Range("c1:c10").Copy
        .Range("d1:d10").PasteSpecial operation:=xlPasteSpecialOperationAdd
    End With
End Sub

jsgj2023

Sub 有效遍历选中单元格区域()
    Dim cell As Range
    If TypeName(Selection) <> "Range" Then Exit Sub
    Const redindex = 3
    Application.ScreenUpdating = False
    For Each cell In Selection
        If cell.Value < 45 Then
            cell.Interior.ColorIndex = 4
        Else
            cell.Interior.ColorIndex = 0
        End If
    Next
    Application.ScreenUpdating = True
End Sub

任浪漫

感谢分享，留个印记。

jsgj2023

'遍历某文件夹及子文件夹中的所有文件
Sub sosuofile(mypath As String)
Dim myname   As String
Dim a As String
Dim b() As String
Dim dir_i() As String
Dim i As Long
Dim idir As Long
If Right(mypath, 1) <> "\" Then mypath = mypath + "\"
myname = Dir(mypath, vbDirectory Or vbHidden Or vbNormal Or vbReadOnly)
Do While myname <> ""
    If myname <> "." And myname <> ".." Then
        If (GetAttr(mypath & myname) And vbDirectory) = vbDirectory Then
            idir = idir + 1
            ReDim Preserve dir_i(idir) As String
            dir_i(idir - 1) = myname
        Else
            list1.AddItem mypath & myname
        End If
    End If
    myname = Dir
Loop
For i = 0 To idir - 1
    Call sosuofile(mypath + dir_i(i))
Next i
ReDim dir_i(0) As String
End Sub