常用代码归集

jsgj2023

Sub 批量对齐图片()
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
        sh.Left = sh.TopLeftCell.Left
    Next
End Sub

jsgj2023

Sub 图片自动适应单元格()
Dim sh  As Shape
For Each sh In ActiveSheet.Shapes
    With sh
        .LockAspectRatio = False
        .Left = .TopLeftCell.Left
        .Top = .TopLeftCell.Top
        .Width = .TopLeftCell.Width
        .Height = .TopLeftCell.Height
    End With
Next
End Sub

jsgj2023

判断选中单元格区域的类型
Function areatype(rangearea As Range) As String
    If rangearea.Areas.Count > 1 Then
        Select Case True
            Case rangearea.Cells.Count = 1
            areatype = "Cell"
            Case rangearea.Cells.Count = Cells.Count
            areatype = "Worksheet"
            Case rangearea.Rows.Count = Cells.Rows.Count
            areatype = "Column"
            Case rangearea.Columns.Count = Cells.Columns.Count
            areatype = "Row"
            Case Else
            areatype = "Block"
        End Select
    Else
    End If
End Function

jsgj2023

Sub 自动导出图表()
On Error Resume Next
Dim chartcount As Integer
Dim activechart As Integer
Dim fd As Object
Dim pathstr As String
Dim chartname As String
With ActiveSheet.ChartObjects
    chartcount = .Count
    If chartcount <= 1 Then Exit Sub
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        If .Show = -1 Then pathstr = .SelectedItems(1) Else Exit Sub
    End With
    If Right(pathstr, 1) <> "\" Then pathstr = pathstr & "\"
    For i = 1 To chartcount
        .Item(i).Chart.Export Filename:=pathstr & IIf(.Item(i).Chart.HasTitle, .Item(i).Chart.ChartTitle.Text, .Item(i).Chart.Name) & ".JPG", filtername:="JPG"
    Next i
End With
End Sub

jsgj2023

Sub 将指定的字符标示为上标()
Dim rng As Range
Dim i As Integer
Dim firststr As String
Dim inputt As String
inputt = InputBox("请输入需要显示为上标的字符", "指定字符", "#")
Application.ScreenUpdating = False
Set rng = Cells.Find(inputt, lookat:=xlPart, LookIn:=xlFormulas)
If Not rng Is Nothing Then
    first = rng.Address
    Do
        For i = 1 To Len(rng)
            If Mid$(rng, i, 1) = Left(inputt, 1) Then rng.Characters(Start:=i, Length:=1).Font.Subscript = True
        Next i
        Set rng = Cells.FindNext(rng)
    Loop Until rng.Address = first
End If
Application.ScreenUpdating = True
End Sub

jsgj2023

Sub evaluate筛选()
Dim rng As Range
Dim cell As Range
For Each rng In Range(Range("c2"), Cells(Rows.Count, 3).End(3))
    If Len(rng.Offset(0, 1)) > 0 Then
        If Evaluate("datedif(" & rng.Address & ", " & rng.Offset(0, 1).Address & ",""M""" & ")") < 12 Then
            If cell Is Nothing Then Set cell = rng Else Set cell = Application.Union(cell, rng)
        End If
    End If
Next
If Not cell Is Nothing Then cell.EntireRow.Hidden = True
End Sub

jsgj2023

Sub 集合法查找最后一次报价()
On Error Resume Next
Dim colt As New Collection
Dim i As Integer
Dim j As Integer
Dim arr As Variant
Dim arr2() As Variant
arr = Range(Range("a1"), Cells(Rows.Count, 3).End(3)).Value
For i = UBound(arr) To 1 Step -1
    colt.Add arr(i, 1), CStr(arr(i, 1))
    If Err = 0 Then
        j = j + 1
        ReDim Preserve arr2(1 To 3, 1 To j)
        arr2(1, j) = colt(j)
        arr2(2, j) = arr(i, 2)
        arr2(3, j) = arr(i, 3)
    End If
    Err.Clear
Next
Range("e1").Resize(j, 3) = Application.Transpose(arr2)
Range("g1").Resize.NumberFormat = "m月d日"
Range("h1").Resize(j, 1) = Evaluate("=row(1:" & j & ")")
Range("e1").Resize(j, 4).Sort key1:=[h1], order1:=xlDescending, ordercustom:=1, Orientation:=xlTopToBottom, dataoption1:=xlSortNormal
Range("h1").Resize(j, 1).Clear
End Sub

jsgj2023

Sub 字典法求第一次报价()
Dim arr()
On Error Resume Next
Set d = CreateObject("scripting.dictionary")
arr = Range("b1:c" & Cells(Rows.Count, 3).End(xlUp).Row)
For i = 1 To UBound(arr)
    d.Add arr(i, 1), arr(i, 2)
Next
[e1].Resize(d.Count) = Application.Transpose(d.keys)
[f1].Resize(d.Count) = Application.Transpose(d.items)
End Sub

jsgj2023

Sub 字典法求最后一次报价()
Dim arr()
Set d = CreateObject("scripting.dictionary")
arr = Range("b1:c" & Cells(Rows.Count, 3).End(xlUp).Row)
For i = 1 To UBound(arr)
    d(arr(i, 1)) = arr(i, 2)
Next
[i1].Resize(d.Count) = Application.Transpose(d.keys)
[j1].Resize(d.Count) = Application.Transpose(d.items)
End Sub

jsgj2023

Sub 多列合并计算_()
Dim arr As Variant
Dim arr1() As Variant
Dim d As Object
Dim i As Integer
Dim n As Integer
Set d = CreateObject("scripting.dictionary")
arr = Range("a2:d" & Cells(Rows.Count, 2).End(3).Row)
For i = 1 To UBound(arr)
     If Not d.exists(arr(i, 1)) Then
        n = n + 1
        d(arr(i, 1)) = n
        ReDim Preserve arr1(1 To 4, 1 To n)
        arr1(1, n) = arr(i, 1)
        arr1(2, n) = arr(i, 2)
        arr1(3, n) = arr(i, 3)
        arr1(4, n) = arr(i, 4)
    Else
        m = d(arr(i, 1))
        arr1(2, m) = arr1(2, m) + arr(i, 2)
        arr1(3, m) = arr1(3, m) + arr(i, 3)
        arr1(4, m) = arr1(4, m) + arr(i, 4)
     End If
Next
[f2].Resize(n, 4) = Application.Transpose(arr1)
End Sub