VBA 依條件及日期自動插入註解

vba excel vba #excel #vba

msmplayv121068 2021-06-02 21:45:57 ‧ 3946 瀏覽

分享至

想請教以下人工插入註解是否有可能以巨集自動插入註解呢？

依 B2:E10 店家、日期、註解內容判斷，自動插入註解至【TEST】活頁對應店家、日期儲存格內。
條件如下：
1. 店家對應開始日期及結束日期，將註解內容插入至【TEST】活頁該日期的業績欄儲存格。
2. 如開始日期與結束日期為不同天，則2天均需插入相同註解內容。例如：B6:E6 ，店家B於6/6、6/30均需各插入一次註解。
3. 如店家為『全店』則將註解插入至日期欄儲存格即可。例如：B5:E5 ，於6/2、6/13均需各插入一次註解。
4. 如結束日為空格則無需理會，例如D3為合併儲存格，故只需6/11插入一次註解即可。

以上目前均為人工插入註解非常耗時，故求網大們解救了~~~~~~~

測試檔 https://drive.google.com/file/d/16Glq5UymFP_yDQvzu5Chdl6FCgQQHtCa/view?usp=sharing

paicheng0111 iT邦大師 5 級 ‧ 2021-06-03 08:18:37 檢舉

你先用錄製巨集功能，把人工流程錄製成VBA，再來改。

msmplayv121068 iT邦新手 4 級 ‧ 2021-06-03 09:30:06 檢舉

P大~~~我試試看

登入發表討論

直播研討會

{{ item.channelVendor }} {{ item.webinarstarted }} |

直播中

3 個回答

rogeryao

iT邦超人 7 級 ‧ 2021-06-03 14:18:43

最佳解答

Private Sub CommandButton1_Click()
' T : TEST
Dim T_SheetName As String
Dim T_X_Start As Integer
Dim T_X_Min As Integer
Dim T_X_Max As Integer
Dim T_YM As String
Dim T_Y_Start As Integer
Dim T_Y_Min As Integer
Dim T_Y_Max As Integer
' S : 註解
Dim S_Y_Start As Integer
Dim S_Y_Min As Integer
Dim S_Y_Max As Integer
Dim U As Integer
Dim M As Integer
Dim P As Integer

T_SheetName = "TEST"
T_X_Start = 2
T_X_Min = T_X_Start + 1
T_X_Max = T_X_Start + 30 * 2 + 1

' 取出 T_SheetName 的年月 2021/06
T_YM = Left(Sheets(T_SheetName).Cells(2, T_X_Start + 1), 7)

T_Y_Start = 3
T_Y_Min = T_Y_Start + 1
T_Y_Max = Worksheets(T_SheetName).Range("B65536").End(xlUp).Row

S_Y_Start = 2
S_Y_Min = S_Y_Start + 1
S_Y_Max = Worksheets("註解").Range("B65536").End(xlUp).Row

' 清除 T_SheetName 日期欄位儲存格顏色及註解
For P = T_X_Min To T_X_Max
  Sheets(T_SheetName).Cells(2, P).Interior.Color = xlNone
  Sheets(T_SheetName).Cells(2, P).ClearComments
Next P

' 清除 T_SheetName 業績欄位儲存格顏色及註解
For M = T_Y_Min To T_Y_Max
  For P = T_X_Min + 1 To T_X_Max + 1 Step 2
    Sheets(T_SheetName).Cells(M, P).Interior.Color = xlNone
    Sheets(T_SheetName).Cells(M, P).ClearComments
  Next P
Next M

For U = S_Y_Min To S_Y_Max
  If (Sheets("註解").Cells(U, 2) = "全店") Then
    ' 開始日期 (U, 3)
    InsertMark T_SheetName, 2, 3, T_YM, T_X_Min, T_X_Max, U
    ' 結束日期 (U, 4)
    InsertMark T_SheetName, 2, 4, T_YM, T_X_Min, T_X_Max, U
  Else
    For M = T_Y_Min To T_Y_Max
      If (Sheets("註解").Cells(U, 2) = Sheets(T_SheetName).Cells(M, 2)) Then
        ' 開始日期 (U, 3)
        InsertMark T_SheetName, M, 3, T_YM, T_X_Min, T_X_Max, U
        ' 結束日期 (U, 4)
        InsertMark T_SheetName, M, 4, T_YM, T_X_Min, T_X_Max, U
        Exit For
      End If
    Next M
  End If
Next U

Sheets(T_SheetName).Activate
End Sub

Sub InsertMark(T_SheetName As String, RowNum As Integer, FieldNum As Integer, T_YM As String, T_X_Min As Integer, T_X_Max As Integer, U As Integer)
Dim K As Integer
Dim G As Integer
Dim StringInsert As String
Dim MarkOld As String
' 相同年月才比對
If (T_YM = Left(Sheets("註解").Cells(U, FieldNum), 7)) Then
  For K = T_X_Min To T_X_Max
    If (Sheets("註解").Cells(U, FieldNum) = Sheets(T_SheetName).Cells(2, K)) Then
      If (RowNum <> 2) Then
        ' 儲存格無合併
        G = K + 1
      Else
        G = K
      End If
      If Sheets(T_SheetName).Cells(RowNum, G).Comment Is Nothing Then
        MarkOld = ""
      Else
        MarkOld = Sheets(T_SheetName).Cells(RowNum, G).Comment.Text
      End If
      ' 刪除註解
      Sheets(T_SheetName).Cells(RowNum, G).ClearComments
      ' 儲存格填顏色
      If FieldNum = 3 Then
        ' 開始日期:淡黃色
        If (Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = 16777215) Or (Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = RGB(255, 255, 0)) Then
          Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = RGB(255, 255, 0)
        Else
          '同一天是開始也是結束:粉紅色
          Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = RGB(255, 0, 255)
        End If
        ' 寫入註解'
        StringInsert = "開始 : " & Sheets("註解").Cells(U, 5) & vbCrLf & MarkOld
      Else
        ' 結束日期:淡藍色
        If (Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = 16777215) Or (Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = RGB(0, 255, 255)) Then
          Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = RGB(0, 255, 255)
        Else
          '同一天是開始也是結束:粉紅色
          Sheets(T_SheetName).Cells(RowNum, G).Interior.Color = RGB(255, 0, 255)
        End If
        ' 寫入註解'
        StringInsert = "結束 : " & Sheets("註解").Cells(U, 5) & vbCrLf & MarkOld
      End If
      Sheets(T_SheetName).Cells(RowNum, G).AddComment StringInsert
      Sheets(T_SheetName).Cells(RowNum, G).Comment.Visible = True
      Exit For
    End If
  Next K
End If

End Sub

開始日期:淡黃色
結束日期:淡藍色
同一天是開始也是結束:粉紅色

回應 2
分享
檢舉

msmplayv121068 iT邦新手 4 級 ‧ 2021-06-04 09:04:00 檢舉

r大~感謝你再次幫忙，讓我得以省下不少人力工作時間啊!!!謝謝~

msmplayv121068 iT邦新手 4 級 ‧ 2021-06-04 15:59:22 檢舉

大~~~你太厲害了吧!!!給你N個讚~哈

登入發表回應

blanksoul12

iT邦研究生 5 級 ‧ 2021-06-03 09:23:34

問題如下

會否有兩間或以上的店在同日同時段出現?
註解最好不要有合併的格

回應 1
分享
檢舉

msmplayv121068 iT邦新手 4 級 ‧ 2021-06-03 09:29:47 檢舉

b大~
1.有喔~例如你看圖一，F~I店，同時5/29開始、6/14結束，所以在【TEST】活頁的對應日期只有6/14的話，就在6/14的對應儲存格插入註解內容。
2. 不會有合併儲存格，這個倒是沒問題~
感謝~

登入發表回應

海綿寶寶

iT邦大神 1 級 ‧ 2021-06-03 14:16:26

解決這個問題還會有下一個
真不知道這是幫你還是害了你...

Excel 的關鍵用途是「計算、統計分析」
不是用來當表格製作報表之用

看貴公司對 Excel 的用法
應該要認真考慮開發應用系統

Sub cellAddComment(ByVal pR As Integer, ByVal pC As Integer, ByVal pComment As String)
    On Error Resume Next
    Sheets("TEST").Cells(pR, pC).AddComment
    'Cells(nR, nC).Comment.Visible = False
    Sheets("TEST").Cells(pR, pC).Comment.Text Text:=pComment
End Sub
Function findRow(ByVal pSearch As String) As Integer
    On Error GoTo NotFound
    
    Sheets("TEST").Cells.Find(What:=pSearch, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , MatchByte:=False, SearchFormat:=False).Activate
        
    Debug.Print "Found " & pSearch & " " & ActiveCell.Row
    findRow = ActiveCell.Row
    
    Exit Function
NotFound:
    Debug.Print "Not Found " & pSearch & " " & ActiveCell.Row
    
    findRow = 0
End Function
Sub findCellAndAddComment(ByVal pStore As String, ByVal pDate As String, ByVal pComment As String)
    nR = findRow(pStore)
    nC = findColumn(pDate)
    If (nR * nC) > 0 Then
        If pStore = "日期" Then
        Else
            nC = findColumn(pDate) + 1
        End If
        
        Call cellAddComment(nR, nC, pComment)
    End If
End Sub
Function findColumn(ByVal pSearch As String) As Integer
    On Error GoTo NotFound
    
    Sheets("TEST").Cells.Find(What:=pSearch, After:=ActiveCell, LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , MatchByte:=False, SearchFormat:=False).Activate
        
    Debug.Print "Found " & pSearch & " " & ActiveCell.Column
    findColumn = ActiveCell.Column
    
    Exit Function
NotFound:
    Debug.Print "Not Found " & pSearch & " " & ActiveCell.Column
    
    findColumn = 0
End Function
Sub MainLoop()
    nRow = 3
    
    Do While Sheets("註解").Cells(nRow, 2) <> ""
        sComment = Sheets("註解").Cells(nRow, 5)
        sStore = Sheets("註解").Cells(nRow, 2)
        If sStore = "全店" Then sStore = "日期"
        
        Debug.Print "---- " & sComment
        
        sDate = Format(Sheets("註解").Cells(nRow, 3), "m/d")
        Call findCellAndAddComment(sStore, sDate, sComment)

        sDate = Format(Sheets("註解").Cells(nRow, 4), "m/d")
        Call findCellAndAddComment(sStore, sDate, sComment)

        nRow = nRow + 1
    Loop
End Sub