常用代码归集

jsgj2023

Sub counta法删除空白列()
  Dim LastColumn As Long
    Dim r As Long
    LastColumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count
    Application.ScreenUpdating = False
    For r = LastColumn To 1 Step -1
        If Application.WorksheetFunction.CountA(Columns(r)) = 0 Then Columns(r).Delete
    Next r
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub counta法删除空白行()
    Dim LastRow As Long
    Dim r As Long
    LastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
    Application.ScreenUpdating = False
    For r = LastRow To 1 Step -1
        If Application.WorksheetFunction.CountA(Rows(r)) = 0 Then Rows(r).Delete
    Next r
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub countif法求2表的交集()
Dim myRange1 As Range
    Dim myRange2 As Range
    Dim myCell As Range
    Dim ws As Worksheet
    Dim i As Long
    With Worksheets
        Set myRange1 = .Item(1).Range("A1").CurrentRegion.Columns(1)
        Set myRange2 = .Item(2).Range("A1").CurrentRegion.Columns(1)
        Set ws = .Add(After:=.Item(.Count))
    End With
    i = 0
    For Each myCell In myRange1.Cells
        If WorksheetFunction.CountIf(myRange2, myCell.Value) = 0 Then
            i = i + 1
            myCell.EntireRow.Copy ws.Cells(i, 1)
        End If
    Next
    For Each myCell In myRange2.Cells
        If WorksheetFunction.CountIf(myRange1, myCell.Value) = 0 Then
            i = i + 1
            myCell.EntireRow.Copy ws.Cells(i, 1)
        End If
    Next
End Sub

jsgj2023

Sub 获取2表重复的数据并copy至新建表格()
Dim myRange1 As Range
    Dim myRange2 As Range
    Dim myCell As Range
    Dim ws As Worksheet
    Dim i As Long
    With Worksheets
        Set myRange1 = .Item(1).Range("A1").CurrentRegion.Columns(1)
        Set myRange2 = .Item(2).Range("A1").CurrentRegion.Columns(1)
        Set ws = .Add(After:=.Item(.Count))
    End With
    i = 0
    For Each myCell In myRange1.Cells
        If WorksheetFunction.CountIf(myRange2, myCell.Value) > 0 Then
            i = i + 1
            myCell.EntireRow.Copy ws.Cells(i, 1)
        End If
    Next
End Sub

jsgj2023

Sub 高级筛选法获取不重复的行数据()
  Dim myRange As Range
    Set myRange = ThisWorkbook.ActiveSheet.Range("A1").CurrentRegion
    myRange.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
End Sub

jsgj2023

Sub 按指定条件筛选并删除不符合条件的数据()
    Dim myRange As Range
    Dim myRangeD As Range
    Dim myRange1 As Range
    Dim myRange2 As Range
    Dim mycell As Range
    Dim ws As Worksheet
    Set myRange1 = Range("A1").CurrentRegion
    Set myRange2 = Range("K1:M3")
    Set myRange = Worksheets(1).Range("A1").CurrentRegion
    With myRange2
        .Cells(1, 1) = "总分"
        .Cells(1, 2) = "班级"
        .Cells(1, 3) = "数学"
        .Cells(2, 1) = ">=360"
        .Cells(2, 2) = "初一2班"
        .Cells(3, 2) = "初一2班"
        .Cells(3, 3) = ">=90"
    End With
    With myRange1
        .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=myRange2
        For Each mycell In myRange2.Cells
            mycell.Clear
        Next
        If MsgBox("是否将没有出现在筛选结果中的所有行删除", vbYesNo _
            + vbQuestion) = vbNo Then GoTo 10000
        Set myRangeD = .SpecialCells(xlCellTypeVisible)
        .AutoFilter
        myRangeD.EntireRow.Hidden = True
        On Error Resume Next
        .SpecialCells(xlCellTypeVisible).EntireRow.Delete
        On Error GoTo 0
        myRangeD.EntireRow.Hidden = False
        .AutoFilter
    End With
10000:
    Set myRange1 = Nothing
    Set myRange2 = Nothing
    Set myRange = Nothing
    Set myRangeD = Nothing
    Set ws = Nothing
End Sub

jsgj2023

Sub 字典查询返回唯一值并有排序()
      Dim arr, brr, x&, y&, z&, d As Object
      Application.ScreenUpdating = False
      Set d = CreateObject("Scripting.Dictionary")
      Set dk = CreateObject("Scripting.Dictionary")
      With Sheets("数据")
      arr = .Range("a1").CurrentRegion
      For x = 2 To UBound(arr)
         s = arr(x, 3) & "+" & arr(x, 5) & "+" & arr(x, 8)
         If Not d.exists(s) Then
             d(s) = Array(arr(x, 10), arr(x, 15), arr(x, 16))
         End If
      Next x
      End With
      dnum = Sheet1.[b1].Value
      For i = 2 To UBound(arr)
         If arr(i, 5) = dnum Then
             If Not dk.exists(arr(i, 3)) Then
                 dk(arr(i, 3)) = ""
             End If
         End If
      Next i
      On Error Resume Next
      Sheet1.Activate
      Range("d2:az2").ClearContents
      Range("d4:az10000").ClearContents
      dname = dk.keys: k = 4
      For j = 0 To dk.Count
         Cells(2, k) = dname(j)
         k = k + 3
     Next
      brr = Range("a1").CurrentRegion
      For y = 4 To UBound(brr)
         For z = 4 To UBound(brr, 2) Step 3
             ss = brr(2, z) & "+" & brr(1, 2) & "+" & brr(y, 2)
             If d.exists(ss) Then
                 Cells(y, z).Resize(1, 3) = d(ss)
             End If
         Next z
     Next y
End Sub

jsgj2023

Sub 调用工作表函数计算矩阵成绩_阶乘等()
    Dim myArray1 As Variant, myArray2 As Variant
    Dim myArrayX As Variant
    myArray1 = Range("A1:C5").Value
    myArray2 = Range("D1:H3").Value
    myArrayX = WorksheetFunction.MMult(myArray1, myArray2)
    Range("J1:N5").Value = myArrayX
    MsgBox "100的阶乘为：" & WorksheetFunction.Fact(100)
    MsgBox "两个数组元素乘积和为：" & WorksheetFunction.SumProduct(myArray1, myArray1)
    MsgBox "单元格区域1的最大值为：" & WorksheetFunction.Max(myArray1)
    MsgBox "单元格区域1的和为：" & WorksheetFunction.Sum(myArray1)
    MsgBox "单元格区域1的平均值为：" & WorksheetFunction.Average(myArray1)
    MsgBox "Sin(30度)值为：" & Sin(30 / 180 * WorksheetFunction.Pi)
    MsgBox "-512.25的绝对值为：" & Abs(-512.25)
End Sub

jsgj2023

Sub days360与datediff函数的区别()
    MsgBox "2006年5月15日至2006年8月22日之间的天数（按每月30天计）为：" _
        & WorksheetFunction.Days360("2006-5-15", "2006-8-22") & "天"
    MsgBox "2006年5月15日至2006年8月22日之间的天数（按实际天数计）为：" _
        & DateDiff("d", #5/15/2006#, #8/22/2006#) & "天"
End Sub

jsgj2023

Sub cint转为整数_cstr转为字符串_cdate转日期_cvar转数值()
    MsgBox "将2345.5678转换为整数：" & CInt(2345.5678)
    MsgBox "将437.324转换为字符串：" & CStr(437.324)
    MsgBox "将8/2/2006转换为Date型日期：" & CDate("8/2/2006")
    MsgBox "将字符串2345.5678转换为数值：" & CVar("2345.5678")
End Sub