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(1)
For Each shp In sh.Shapes
'思路判斷:有時圖片會跨越兩個單元格,這時就需要比較圖片的高度和單元格的高度,更好的思路是先將圖片尺寸縮小一半,如,然後再進行調整
With shp
shp.Name = shp.Name & Round(Rnd() * 125, 1)
shp.Top = shp.Top + shp.Height / 2
shp.Left = shp.Left + shp.Width / 2
shp.Height = shp.Height / 8 '先縮小圖片,以防出現佔據多個單元格的問題
shp.Width = shp.Width / 8
'.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 ' + 2
.Top = shp.TopLeftCell.MergeArea.Top + (ht - .Height) / 2
Else
.Height = ht * 圖片顯示比例
.Width = .Height * bl
.Top = shp.TopLeftCell.MergeArea.Top + (ht - .Height) / 2
.Left = shp.TopLeftCell.MergeArea.Left + (wt - .Width) / 2
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(1)
For Each shp In sh.Shapes
dic.Add shp.TopLeftCell.Row, shp.Name
Next
b = dic.keys
C = 數組升序(b)
For i = 0 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(1)
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(1)
Aend = sh.Range("a65536").End(3).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, 1
End If
Next
End Sub
Sub test()
Dim arr(99)
For i = 1 To 10
t = Int(Rnd() * 100)
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 = 1 To 10
objSortedlist.Add Range("A" & i).Value, Range("A" & i).Value
Next i
For i = 0 To objSortedlist.Count - 1
Debug.Print objSortedlist.GetKey(i)
Next
End Sub
Sub Arraylist()
Set objArrayList = CreateObject("System.Collections.ArrayList")
For i = 1 To 10
objArrayList.Add Range("A" & i).Value
Next i
objArrayList.Sort
For i = 0 To objArrayList.Count - 1
Debug.Print objArrayList(i)
Next
End Sub
Sub test2()
brr = WorksheetFunction.Transpose([a1:a100&"-"])
For i = 1 To 10
t = Int(Rnd() * 100 + 1)
brr(t) = t
Next
Debug.Print Join(Filter(brr, "-", False), ";")
End Sub
Sub test3()
Dim arr(-99 To 99)
For i = 1 To 20
t = Int(Rnd() * 199 - 99)
arr(t) = t & ";"
Next
Debug.Print Replace(Join(arr), " ", "")
End Sub
'在介紹具體方法之前,先給個數組生成過程。(將數組a(1 to 50)定義成公用數組)
Sub MakeArr()
For i = 1 To 50
a(i) = Int(Rnd(1) * 890 + 10)
Next i
End Sub
'1 ?快速排序法
Sub FastSort()
M = 1
For i = 1 To 49
If a(i) <= a(i + 1) Then
If i > M Then
M = i
Else
i = M
End If
GoTo kk:
Else
x = a(i)
a(i) = a(i + 1)
a(i + 1) = x
If i <> 1 Then i = i - 2
End If
kk:
Next i
End Sub
'2 ?冒泡排序法
Sub BubbleSort()
For i = 1 To 49
For j = i + 1 To 50
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 = 2 To 50
tempnum = a(i)
Index = i
Do
If Index > 1 Then
If tempnum < a(Index - 1) Then
a(Index) = a(Index - 1)
Index = Index - 1
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 = 50
skipnum = Int((Size / 2)) - 1
Do While skipnum > 0
i = 1 + skipnum
For j = i To 50
Index = j
Do
If Index >= (1 + 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 - 1) / 2
Loop
End Sub
'5 ?選擇排序法
Sub SelectionSort()
Dim Index
Dim Min
Dim i
Dim tempnum
BzArr
i = 1
While (i < 50)
Min = 50
Index = Min - 1
While (Index >= i)
If a(Index) < a(Min) Then
Min = Index
End If
Index = Index - 1
Wend
tempnum = a(Min)
a(Min) = a(i)
a(i) = tempnum
i = i + 1
Wend
End Sub
'以上五種排序方法均是數組排序的常用方法,優點是不需藉助輔助單元格。執行效率視數組成員的相對有序性的不同而不同。以附件中的50位一維數組爲例,快速排序法的循環次數是745次、冒泡法的循環次數是1225次、桶排序法的循環次數是704次、希爾排序法的循環次數是347次、選擇排序法的循環次數爲1225次。
'下面再介紹兩種用EXCEL函數的排序方法,一般來說使用EXCEL自帶函數或方法的執行效率會高一些,但限於函數參數的限制有的不得不藉助於輔助單元格。
'6 ?SMALL函數法
Sub SmallSort()
Dim b(1 To 50)
For i = 1 To 50
b(i) = Application.WorksheetFunction.Small(a, i)
Next
End Sub
'原數組不變,生成一個新的按升序排列的數組。同理也可以用LARGE函數?我個人覺得用這種方法較快?
'7 ?RANK函數法
Sub RankSort()
BzArr
Dim b(1 To 50)
For i = 1 To 50
Sheet2.Cells(i, 1) = a(i)
Next
Set rankrange = Sheet2.Range("a1:a50")
For i = 1 To 50
For k = 0 To Application.WorksheetFunction.CountIf(rankrange, Sheet2.Cells(i, 1)) - 1
j = Application.WorksheetFunction.Rank(Sheet2.Cells(i, 1), rankrange, 1)
a(j + k) = Sheet2.Cells(i, 1)
Next
Next
For i = 1 To 50
Sheet1.Cells(i + 2, 7) = a(i)
Next
End Sub
'此方法的缺點是需要藉助輔助單元格?
Excel數組排序+圖片調整大小
發表評論
所有評論
還沒有人評論,想成為第一個評論的人麼? 請在上方評論欄輸入並且點擊發布.