返回列表 上一主題 發帖

Excel VBA如何檢查_細長物件數量

Excel VBA如何檢查_細長物件數量

各位前輩好
1.請教 檢查_細長物件數量 的程式碼
2.這程式的目的是為了檢查因儲存格刪除,而物件被細扁化藏在工作表裡,經使用者無意複製 不自知,導致檔案變大
2.1.以下程式碼是自己想的土方法
3.有其它方法嗎?
4.Andy想進步!請指教

請各位前輩指教 謝謝

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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

謝謝前輩們指導
1.舉一反三,用抄改方式套用
2.對Function()還懵懂,但測試還ok
3.請前輩們再指導

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

自問自答了
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

本帖最後由 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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

請各位前輩再指導 謝謝
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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

請各位前輩再指導 謝謝
1.Function()是這樣用嗎?
2.兩個Function()可以合併成一個Function(),傳兩個值給主程式嗎?

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
看得懂是應該的,懂得應用才像學生,臉皮厚點學會更謹慎積極

TOP

        靜思自在 : 生氣,就是拿別人的過錯來懲罰自己。
返回列表 上一主題