fork download
  1. Option Explicit
  2. Dim ms As Worksheet '明細シート
  3. Dim sz As Worksheet '処理済シート
  4. Dim maxrow_ms As Long '明細最大行
  5. Dim maxrow_sz As Long '処理済最大行
  6. Dim count As Long '処理件数
  7.  
  8. Public Sub 更新処理()
  9. Dim ret As Integer
  10. Set ms = Worksheets("明細")
  11. Set sz = Worksheets("処理済")
  12. maxrow_ms = ms.Cells(Rows.count, 1).End(xlUp).Row 'A列 最大行取得
  13. maxrow_sz = sz.Cells(Rows.count, 1).End(xlUp).Row 'A列 最大行取得
  14. count = 0
  15. ms.Range("E2:E" & maxrow_ms).Value = "" '状態クリア
  16. Call check_status("建物") '建物シートのチェック
  17. Call check_status("機械") '機械シートのチェック
  18. If count = 0 Then
  19. MsgBox ("処理済データなし")
  20. Exit Sub
  21. End If
  22. ret = MsgBox("処理件数=" & count & vbLf & "完了データの移動及び処理済データの削除を開始します", vbOKCancel)
  23. If ret = vbCancel Then Exit Sub
  24. Call delete_line("建物") '建物シートの処理済み行削除
  25. Call delete_line("機械") '機械シートの処理済み行削除
  26. Call copy_compline '完了行のコピー
  27. Call delete_compline '完了行の削除
  28. MsgBox ("処理完了")
  29. End Sub
  30. '処理済行のチェック
  31. Private Sub check_status(ByVal sheet_name As String)
  32. Dim maxrow As Long
  33. Dim ws As Worksheet
  34. Dim wrow As Long
  35. Dim result As Boolean
  36. Dim name As String
  37. Dim kingaku As Variant
  38. Dim errmsg As String
  39. errmsg = ""
  40. Set ws = Worksheets(sheet_name)
  41. maxrow = ws.Cells(Rows.count, 2).End(xlUp).Row 'B列 最大行取得
  42. For wrow = 2 To maxrow
  43. If ws.Cells(wrow, "B").Value = "処理済" Then
  44. name = ws.Cells(wrow, "C").Value
  45. kingaku = ws.Cells(wrow, "D").Value
  46. If kingaku = "" Then errmsg = "合計金額が空です"
  47. If name = "" Then errmsg = "名前が空です"
  48. If errmsg = "" Then
  49. Call check_kingaku(name, kingaku, errmsg) '合計金額のチェック
  50. End If
  51. 'エラーがあればエラーメッセージ表示後、処理中止
  52. If errmsg <> "" Then
  53. MsgBox ("シート名=" & sheet_name & " " & wrow & "行" & vbLf & errmsg & vbLf & "処理を打ち切ります")
  54. ws.Select
  55. ws.Cells(wrow, "B").Select
  56. End
  57. End If
  58. End If
  59. Next
  60. End Sub
  61.  
  62. '金額チェック
  63. Private Sub check_kingaku(ByVal name As String, ByVal kingaku As Variant, ByRef errmsg As String)
  64. Dim wrow As Long
  65. Dim find As Boolean
  66. find = False
  67. For wrow = 2 To maxrow_ms
  68. If ms.Cells(wrow, "E").Value = "" And ms.Cells(wrow, "B").Value = name Then
  69. If ms.Cells(wrow, "D").Value = kingaku Then
  70. ms.Cells(wrow, "E").Value = "完了"
  71. count = count + 1
  72. Exit Sub
  73. End If
  74. find = True
  75. End If
  76. Next
  77. If find = True Then
  78. errmsg = "合計金額が不一致です"
  79. Else
  80. errmsg = "名前が不一致です"
  81. End If
  82. End Sub
  83.  
  84. '処理済行の削除
  85. Private Sub delete_line(ByVal sheet_name As String)
  86. Dim maxrow As Long
  87. Dim ws As Worksheet
  88. Dim wrow As Long
  89. Set ws = Worksheets(sheet_name)
  90. maxrow = ws.Cells(Rows.count, 2).End(xlUp).Row 'B列 最大行取得
  91. For wrow = maxrow To 2 Step -1
  92. If ws.Cells(wrow, "B").Value = "処理済" Then
  93. ws.Rows(wrow).Delete
  94. End If
  95. Next
  96. End Sub
  97.  
  98. '完了行のコピー
  99. Private Sub copy_compline()
  100. Dim wrow As Long
  101. Dim wrow2 As Long
  102. wrow2 = maxrow_sz
  103. For wrow = 2 To maxrow_ms
  104. If ms.Cells(wrow, "E").Value = "完了" Then
  105. sz.Range("A" & wrow2 & ":E" & wrow2).Value = ms.Range("A" & wrow & ":E" & wrow).Value
  106. wrow2 = wrow2 + 1
  107. End If
  108. Next
  109. End Sub
  110.  
  111. '完了行の削除
  112. Private Sub delete_compline()
  113. Dim wrow As Long
  114. Dim wrow2 As Long
  115. wrow2 = maxrow_sz
  116. For wrow = maxrow_ms To 2 Step -1
  117. If ms.Cells(wrow, "E").Value = "完了" Then
  118. ms.Rows(wrow).Delete
  119. End If
  120. Next
  121. End Sub
  122.  
  123.  
Not running #stdin #stdout 0s 0KB
stdin
Standard input is empty
stdout
Standard output is empty