Sub 檢查_細長物件數量()
Dim doN&, doNerr&, i&, msg$, SSH&, SHW&
With ActiveSheet.DrawingObjects
If .Count = 0 Then
GoTo 101
End If
For i = 1 To .Count
doN = doN + 1
ActiveSheet.DrawingObjects(i).Select
SSH = Selection.ShapeRange.Height
SHW = Selection.ShapeRange.Width
If Selection.ShapeRange.Type <> 9 Then '9:線條
If SSH < 1 Or SHW < 1 Then
doNerr = doNerr + 1
End If
End If
Next
End With
101
[A1].Select
If doN > 0 Then
msg = "1.共有: " & doN & " 個物件(圖片.文字框...等)" & Chr(10)
Else
msg = "在工作表中沒有 物件(圖片.文字框...)"
End If
If doNerr > 0 Then
msg = msg & "2.其中共有: " & doNerr & " 個細長物件(圖片.文字框...)藏在工作表中" & _
Chr(10) & "2.1.建議刪除這 " & doNerr & " 個細長物件"
ElseIf doN > 0 Then
msg = "沒有 細長物件(圖片.文字框...)藏在工作表中"
End If
ck_K = "檢查_細長物件數量"
ck_Q = doNerr
ck_W = msg
If doNerr > 0 Then
ck_AC = "程式可以自動去除細長物件"
Call 設清單_I欄
Call 當列上色
Else
ck_AC = "NA"
End If
End Sub作者: Andy2483 時間: 2020-8-11 20:22
Option Explicit
Sub 檢查_物件數量()
Dim Msg As String
With ActiveSheet
If .DrawingObjects.Count > 0 Then Msg = "[附註] 有" & .DrawingObjects.Count & "個 " & 物件數量副程式(.DrawingObjects)
If Msg <> "" Then Msg = Msg & String(2, vbLf)
If Msg = "" Then Msg = .Name & " 沒有任何 物件...."
MsgBox Msg
End With
End Sub
Function 物件數量副程式(draw As Object) As String
Dim e As Object, 物件 As String
For Each e In draw
物件 = 物件 & IIf(物件 <> "", vbLf, "") & e.TopLeftCell.Address & " " & e.Text
Next
物件數量副程式 = vbLf & 物件
End Function
自問自答了作者: Andy2483 時間: 2020-8-12 09:15
本帖最後由 Andy2483 於 2020-8-12 09:16 編輯
請各位前輩再指導 謝謝
1.並不是所有DrawingObjects都有文字,所以修改再研習的程式碼如下
2.物件數量副程式(.DrawingObjects)是指這副程式要回傳一個有關於現工作表 繪圖物件的值 的意思?
3.物件數量副程式(draw As Object) As String 是指
3.1.回傳給2.一個字串的值,等於是宣告 物件數量副程式 這幾個字是副程式也是字串變數的意思嗎?
3.2.這 draw As Object 是等於 ActiveSheet.DrawingObjects ?
3.3.(.DrawingObjects)跟(draw As Object)屬性要相同,相互呼應?
3.4.(draw As Object) draw在括弧裡宣告是物件變數?
Option Explicit
Sub 檢查_物件數量()
Dim msg As String
With ActiveSheet
If .DrawingObjects.Count > 0 Then msg = "[物件] 有" & .DrawingObjects.Count & "個 " & 物件數量副程式(.DrawingObjects)
If msg <> "" Then msg = msg & String(2, vbLf)
If msg = "" Then msg = .Name & " 沒有任何 物件...."
MsgBox msg
End With
End Sub
Function 物件數量副程式(draw As Object) As String
Dim e As Object, 物件 As String
For Each e In draw
物件 = 物件 & IIf(物件 <> "", vbLf, "") & e.TopLeftCell.Address
Next
物件數量副程式 = vbLf & 物件
End Function作者: Andy2483 時間: 2020-8-12 14:35
請各位前輩再指導 謝謝
1.學會運用 Const
2.學會運用IIF
謝謝前輩們指導
Option Explicit '強制宣告變數
Const HW = 1 '物件的高或寬
Sub 檢查_細長物件數量()
Dim doN&, msg$, doERRN&, TLC$, drob As Object, SSS&
msg = "有細長物件儲存格格位: "
For Each drob In ActiveSheet.DrawingObjects '此工作表 繪圖物件'集合'
With drob '針對所有繪圖物件
If (.Height < HW Or .Width < HW) And .ShapeRange.Type <> 9 Then '符合條件判斷式 '9:水平或垂直線條會被誤判 所以除外
doERRN = doERRN + 1 '累加細長物件數量
TLC = .TopLeftCell.Address & "." '用TLC 裝位址字串,程式比較簡潔
msg = msg & IIf(msg Like "*" & TLC & "*", "", TLC) '如果多物件在同格!就不再重複出現格位址
End If
End With
Next
msg = msg & " 共 " & doERRN & " 個"
If doERRN = 0 Then msg = "沒有細長物件"
MsgBox msg
End Sub
Sub 細長物件刪除()
Dim drob As Object
For Each drob In ActiveSheet.DrawingObjects '此工作表 繪圖物件'集合'
With drob '針對所有繪圖物件
If (.Height < HW Or .Width < HW) And .ShapeRange.Type <> 9 Then '符合條件判斷式 '9:水平或垂直線條會被誤判 所以除外
.Delete
End If
End With
Next
End Sub作者: Andy2483 時間: 2020-8-12 15:23
Option Explicit
Const HW = 1 '物件的高或寬
Sub 檢查_物件數量_1()
Dim msg As String
With ActiveSheet
If 物件數量(.DrawingObjects) > 0 Then msg = "[物件] 有" & 物件數量(.DrawingObjects) & "個 " & 物件數量位址集(.DrawingObjects)
If msg <> "" Then msg = msg & String(2, vbLf)
If msg = "" Then msg = .Name & " 沒有任何 物件...."
MsgBox msg
End With
End Sub
Function 物件數量位址集(draw As Object) As String 'Integer
Dim e As Object, 物件 As String, TLC$
For Each e In draw
If (e.Height < HW Or e.Width < HW) And e.ShapeRange.Type <> 9 Then
TLC = e.TopLeftCell.Address & "."
物件 = 物件 & IIf(物件 Like "*" & TLC & "*", "", TLC)
End If
Next
物件數量位址集 = vbLf & 物件
End Function
Function 物件數量(draw As Object) As Integer
Dim e As Object, 數量 As Integer
For Each e In draw
If (e.Height < HW Or e.Width < HW) And e.ShapeRange.Type <> 9 Then
數量 = 數量 + 1
End If
Next
物件數量 = 數量
End Function
