Sub 图片调整合适大小()

'    Debug.Print ActiveWorkbook.Name

    图片显示比例 = 0.9    '1为顶满单元格

    Dim wb As Workbook, sh As Worksheet, ce As Range, shp As Shape

    Dim dic As Object, re As Object, shel As Object, WS As Object, FSO As Object

    Dim arr(), brr()    'Redim preserve arr(i)

    Set dic = CreateObject("scripting.dictionary")

    Set wb = ActiveWorkbook

    Set sh = wb.Sheets()

    For Each shp In sh.Shapes

        '思路判断:有时图片会跨越两个单元格,这时就需要比较图片的高度和单元格的高度,更好的思路是先将图片尺寸缩小一半,如，然后再进行调整

        With shp

        shp.Name = shp.Name & Round(Rnd() * , )

            shp.Top = shp.Top + shp.Height /

            shp.Left = shp.Left + shp.Width /

            shp.Height = shp.Height /     '先缩小图片,以防出现占据多个单元格的问题

            shp.Width = shp.Width / 

            '.Name = .Name & Rnd(1000)

            '--------------------------------------------------------------

            wt = shp.TopLeftCell.MergeArea.Width  '单元格区域宽度；

            ht = shp.TopLeftCell.MergeArea.Height    '单元格区域高度

            bl = .Width / .Height

            If wt / ht < bl Then

                .Width = wt * 图片显示比例  ' sh0.Cells(st_mid2, 1).Width

                .Height = .Width / bl

                .Left = shp.TopLeftCell.MergeArea.Left + (wt - .Width) /   ' + 2

                .Top = shp.TopLeftCell.MergeArea.Top + (ht - .Height) /

            Else

                .Height = ht * 图片显示比例

                .Width = .Height * bl

                .Top = shp.TopLeftCell.MergeArea.Top + (ht - .Height) /

                .Left = shp.TopLeftCell.MergeArea.Left + (wt - .Width) /

            End If

        End With

    Next

End Sub

Sub 图片统一()

    Dim wb As Workbook, sh As Worksheet, ce As Range, shp As Shape

    Dim dic As Object, re As Object, shel As Object, WS As Object, FSO As Object

    Dim arr(), brr()    'Redim preserve arr(i)

    Set dic = CreateObject("scripting.dictionary")

    Set wb = ActiveWorkbook

    Set sh = wb.Sheets()

    For Each shp In sh.Shapes

        dic.Add shp.TopLeftCell.Row, shp.Name

    Next

    b = dic.keys

    C = 数组升序(b)

    For i =  To UBound(b)

        Debug.Print b(i), C(i)

    Next

End Sub

Function 数组升序(arr)

    Set js = CreateObject("msscriptcontrol.scriptcontrol")

    js.Language = "javascript"

    'arr = Application.Transpose(Range("A1:A10"))

    TEMP = Join(arr, ",")

    js.addcode "function aa(bb){js=bb.split(',');js.sort(function(a,b){return a-b;});return js;}"

    sortarr = js.eval("aa('" & TEMP & "')")

    数组升序 = Split(sortarr, ",")

End Function

Sub 图片统一大小()

    Dim wb As Workbook, sh As Worksheet, ce As Range, shp As Shape

    Dim wb As Workbook, sh As Worksheet, ce As Range, shp As Shape

    Dim dic As Object, re As Object, shel As Object, WS As Object, FSO As Object

    Dim arr(), brr()    'Redim preserve arr(i)

    Set dic = CreateObject("scripting.dictionary")

    Set wb = ActiveWorkbook

    Set sh = wb.Sheets()

    Set shp = Selection

End Sub

Sub 重复标红()

    Dim wb As Workbook, sh As Worksheet, ce As Range, shp As Shape

    Dim dic As Object, re As Object, shel As Object, WS As Object, FSO As Object

    Dim arr(), brr()    'Redim preserve arr(i)

    Set dic = CreateObject("scripting.dictionary")

    Set wb = ActiveWorkbook

    Set sh = wb.Sheets()

    Aend = sh.Range("a65536").End().Row

    For Each ce In sh.Range("a1:a" & Aend)

        If dic.exists(ce.Value) Then

            ce.Interior.Color = vbRed

        Else

            dic.Add ce.Value,

        End If

    Next

End Sub

Sub test()

    Dim arr()

    For i =  To

        t = Int(Rnd() * )

        arr(t) = t & ";"

    Next

    Debug.Print Replace(Join(arr), " ", "")

End Sub

Sub 文本升序()

    Set js = CreateObject("msscriptcontrol.scriptcontrol")

    js.Language = "javascript"

    arr = Application.Transpose(Range("A1:A10"))

    TEMP = Join(arr, ",")

    js.addcode "function aa(bb){js=bb.split(',');js.sort();return js;}"

    sortarr = js.eval("aa('" & TEMP & "')")

    Debug.Print sortarr

End Sub

Sub 文本降序()

    Set js = CreateObject("msscriptcontrol.scriptcontrol")

    js.Language = "javascript"

    arr = Application.Transpose(Range("A1:A10"))

    TEMP = Join(arr, ",")

    js.addcode "function aa(bb){js=bb.split(',');js.sort();js.reverse();return js;}"

    sortarr = js.eval("aa('" & TEMP & "')")

    Debug.Print sortarr

End Sub

Sub 数值升序()

    Set js = CreateObject("msscriptcontrol.scriptcontrol")

    js.Language = "javascript"

    arr = Application.Transpose(Range("A1:A10"))

    TEMP = Join(arr, ",")

    js.addcode "function aa(bb){js=bb.split(',');js.sort(function(a,b){return a-b;});return js;}"

    sortarr = js.eval("aa('" & TEMP & "')")

    Debug.Print sortarr

End Sub

Sub 数值降序()

    Set js = CreateObject("msscriptcontrol.scriptcontrol")

    js.Language = "javascript"

    arr = Application.Transpose(Range("A1:A10"))

    TEMP = Join(arr, ",")

    js.addcode "function aa(bb){js=bb.split(',');js.sort(function(a,b){return a-b;});js.reverse();return js;}"

    sortarr = js.eval("aa('" & TEMP & "')")

    Debug.Print sortarr

End Sub

Sub Sortlist()    '但需要系统支持Framework

    Set objSortedlist = CreateObject("System.Collections.Sortedlist")

    For i =  To

        objSortedlist.Add Range("A" & i).Value, Range("A" & i).Value

    Next i

    For i =  To objSortedlist.Count -

        Debug.Print objSortedlist.GetKey(i)

    Next

End Sub

Sub Arraylist()

    Set objArrayList = CreateObject("System.Collections.ArrayList")

    For i =  To

        objArrayList.Add Range("A" & i).Value

    Next i

    objArrayList.Sort

    For i =  To objArrayList.Count -

        Debug.Print objArrayList(i)

    Next

End Sub

Sub test2()

    brr = WorksheetFunction.Transpose([a1:a100&"-"])

    For i =  To

        t = Int(Rnd() *  + )

        brr(t) = t

    Next

    Debug.Print Join(Filter(brr, "-", False), ";")

End Sub

Sub test3()

    Dim arr(- To )

    For i =  To

        t = Int(Rnd() *  - )

        arr(t) = t & ";"

    Next

    Debug.Print Replace(Join(arr), " ", "")

End Sub

'在介绍具体方法之前，先给个数组生成过程。(将数组a(1 to 50)定义成公用数组)

Sub MakeArr()

    For i =  To

        a(i) = Int(Rnd() *  + )

    Next i

End Sub

'1 ?快速排序法

Sub FastSort()

    M =

    For i =  To

        If a(i) <= a(i + ) Then

            If i > M Then

                M = i

            Else

                i = M

            End If

            GoTo kk:

        Else

            x = a(i)

            a(i) = a(i + )

            a(i + ) = x

            If i <>  Then i = i -

        End If

kk:

    Next i

End Sub

'2 ?冒泡排序法

Sub BubbleSort()

    For i =  To

        For j = i +  To

            If a(i) > a(j) Then

                TEMP = a(j)

                a(j) = a(i)

                a(i) = TEMP

            End If

        Next j

    Next i

End Sub

'3 ?桶排序法

Sub Bucket()

    Dim Index

    Dim tempnum

    For i =  To

        tempnum = a(i)

        Index = i

        Do

            If Index >  Then

                If tempnum < a(Index - ) Then

                    a(Index) = a(Index - )

                    Index = Index -

                Else

                    Exit Do

                End If

            Else

                Exit Do

            End If

        Loop

        a(Index) = tempnum

    Next

End Sub

'4 ?希尔排序法

Sub ShellSort()

    Dim skipnum

    Dim Index

    Dim i

    Dim tempnum

    Size =

    skipnum = Int((Size / )) -

    Do While skipnum >

        i =  + skipnum

        For j = i To

            Index = j

            Do

                If Index >= ( + skipnum) Then

                    If a(Index) < a(Index - skipnum) Then

                        tempnum = a(Index)

                        a(Index) = a(Index - skipnum)

                        a(Index - skipnum) = tempnum

                        Index = Index - skipnum

                    Else

                        Exit Do

                    End If

                Else

                    Exit Do

                End If

            Loop

        Next

        skipnum = (skipnum - ) /

    Loop

End Sub

'5 ?选择排序法

Sub SelectionSort()

    Dim Index

    Dim Min

    Dim i

    Dim tempnum

    BzArr

    i =

    While (i < )

        Min =

        Index = Min -

        While (Index >= i)

            If a(Index) < a(Min) Then

                Min = Index

            End If

            Index = Index -

        Wend

        tempnum = a(Min)

        a(Min) = a(i)

        a(i) = tempnum

        i = i +

    Wend

End Sub

'以上五种排序方法均是数组排序的常用方法，优点是不需借助辅助单元格。执行效率视数组成员的相对有序性的不同而不同。以附件中的50位一维数组为例，快速排序法的循环次数是745次、冒泡法的循环次数是1225次、桶排序法的循环次数是704次、希尔排序法的循环次数是347次、选择排序法的循环次数为1225次。

'下面再介绍两种用EXCEL函数的排序方法，一般来说使用EXCEL自带函数或方法的执行效率会高一些，但限于函数参数的限制有的不得不借助于辅助单元格。

'6 ?SMALL函数法

Sub SmallSort()

    Dim b( To )

    For i =  To

        b(i) = Application.WorksheetFunction.Small(a, i)

    Next

End Sub

'原数组不变，生成一个新的按升序排列的数组。同理也可以用LARGE函数?我个人觉得用这种方法较快?

'7 ?RANK函数法

Sub RankSort()

    BzArr

    Dim b( To )

    For i =  To

        Sheet2.Cells(i, ) = a(i)

    Next

    Set rankrange = Sheet2.Range("a1:a50")

    For i =  To

        For k =  To Application.WorksheetFunction.CountIf(rankrange, Sheet2.Cells(i, )) -

            j = Application.WorksheetFunction.Rank(Sheet2.Cells(i, ), rankrange, )

            a(j + k) = Sheet2.Cells(i, )

        Next

    Next

    For i =  To

        Sheet1.Cells(i + , ) = a(i)

    Next

End Sub

'此方法的缺点是需要借助辅助单元格?