Jun
8,
2023

Excel-vba

Excelの31Sheetsのすべてを集計するVBA
06：00から20：00を30分刻みで分け、その時間帯での作業数を集計する。
作業数がよって着色する機能を持たせ、作業が輻輳する日と時間帯を可視化する。


Attribute VB_Name = "Module18"
Option Explicit

Sub SYUKEI1()
Attribute SYUKEI1.VB_ProcData.VB_Invoke_Func = " \n14"
'
' SYUKEI1 Macro
'
Dim i, j, k As Long
Dim Sht_nam_c(30) As String
Dim Skd_day_c(31) As String
Dim IN_job_c As String
Dim BS_job_c As String
Dim Num_n As Long

Dim Fst_job_n(36) As Long
Dim Snd_job_n(36) As Long

Dim Cnt1_n As Long
Dim Cnt2_n As Long

Dim Up_n As Long

Dim Max_n As Integer

Dim Max_c As String

BS_job_c = "B1B2B3C1C2C3C4C5C6C7D1D2D3D4E1F2F3F4H"

'------------------------------------------------

Sht_nam_c(1) = "RM102"
Sht_nam_c(2) = "RM103"
Sht_nam_c(3) = "RM105"
Sht_nam_c(4) = "RM106"
Sht_nam_c(5) = "RM107"
Sht_nam_c(6) = "RM108"
Sht_nam_c(7) = "RM110"
Sht_nam_c(8) = "RM111"
Sht_nam_c(9) = "RM112"
'-----------------------
Sht_nam_c(10) = "RM201"
Sht_nam_c(11) = "RM202"
Sht_nam_c(12) = "RM203"
Sht_nam_c(13) = "RM205"
Sht_nam_c(14) = "RM206"
Sht_nam_c(15) = "RM207"
Sht_nam_c(16) = "RM208"
Sht_nam_c(17) = "RM210"
Sht_nam_c(18) = "RM211"
Sht_nam_c(19) = "RM212"
Sht_nam_c(20) = "RM213"
Sht_nam_c(21) = "RM215"
Sht_nam_c(22) = "RM216"
Sht_nam_c(23) = "RM217"
Sht_nam_c(24) = "RM218"
Sht_nam_c(25) = "RM220"

'---------------------------------------

Skd_day_c(1) = "FRSKD-01"
Skd_day_c(2) = "FRSKD-02"
Skd_day_c(3) = "FRSKD-03"
Skd_day_c(4) = "FRSKD-04"
Skd_day_c(5) = "FRSKD-05"
Skd_day_c(6) = "FRSKD-06"
Skd_day_c(7) = "FRSKD-07"
Skd_day_c(8) = "FRSKD-08"
Skd_day_c(9) = "FRSKD-09"

Skd_day_c(10) = "FRSKD-10"
Skd_day_c(11) = "FRSKD-11"
Skd_day_c(12) = "FRSKD-12"
Skd_day_c(13) = "FRSKD-13"
Skd_day_c(14) = "FRSKD-14"
Skd_day_c(15) = "FRSKD-15"
Skd_day_c(16) = "FRSKD-16"
Skd_day_c(17) = "FRSKD-17"
Skd_day_c(18) = "FRSKD-18"
Skd_day_c(19) = "FRSKD-19"

Skd_day_c(20) = "FRSKD-20"
Skd_day_c(21) = "FRSKD-21"
Skd_day_c(22) = "FRSKD-22"
Skd_day_c(23) = "FRSKD-23"
Skd_day_c(24) = "FRSKD-24"
Skd_day_c(25) = "FRSKD-25"
Skd_day_c(26) = "FRSKD-26"
Skd_day_c(27) = "FRSKD-27"
Skd_day_c(28) = "FRSKD-28"
Skd_day_c(29) = "FRSKD-29"

Skd_day_c(30) = "FRSKD-30"
Skd_day_c(31) = "FRSKD-31"


Max_c = InputBox("日別の予定を一覧表に集計します" & Chr(13) & "上限値は?", , 3)

Max_n = Val(Max_c)

'----------------------------------------
Application.ScreenUpdating = False
'---------------------------------------
'
Up_n = 0

For i = 1 To 31

Sheets(Skd_day_c(i)).Select

     For j = 5 To 36
     
           Cnt1_n = 0
           Cnt2_n = 0
           
     
         For k = 2 To 10     ' 1Fの集計
                  
               If Cells(j, k) = "" And Cells(j, k).Interior.ColorIndex = -4142 Then
               
                Else
               
                 If Cells(j, k) = "C6" Or Cells(j, k) = "D2" Or Cells(j, k) = "=" Then
              
                  Cnt1_n = Cnt1_n + 2
                
                 Else
                
                  Cnt1_n = Cnt1_n + 1
                 
                 End If
            
               
                End If
     
         Next k
         
         Fst_job_n(j) = Cnt1_n
         
         
         For k = 11 To 26    '2Fの集計
                        
               If Cells(j, k) = "" And Cells(j, k).Interior.ColorIndex = -4142 Then
               
                 Else
               
                
               If Cells(j, k) = "C6" Or Cells(j, k) = "D2" Or Cells(j, k) = "=" Then
              
                  Cnt2_n = Cnt2_n + 2
                
                Else
                
                  Cnt2_n = Cnt2_n + 1
                 
                End If
                
          
               End If
               
         Next k
          
          Snd_job_n(j) = Cnt2_n
         
     Next j
     
     Sheets("SKD-ALL").Select

    
     
     For j = 5 To 36
     
     
     Cells(j, i + Up_n + 1) = Fst_job_n(j)
     
     Cells(j, i + Up_n + 2) = Snd_job_n(j)
     
     
     Next j
     
    Up_n = Up_n + 1
    
     
Next i

Sheets("SKD-ALL").Select


Range("B5:BK36").Select       '　文字色の初期化
    With Selection.Font
        .Name = "游ゴシック"
        .FontStyle = "標準"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    
    
For i = 5 To 36
       
       For j = 2 To 63
       
       If Cells(i, j) >= Max_n Then
            
          Cells(i, j).Font.ColorIndex = 3 ' 3以上は赤
          
       End If
       
       If Cells(i, j) = 0 Then
            
          Cells(i, j) = ""
          
       End If
       
       Next j
       
Next i

Range("A3") = "MAX " & Max_n

Range("A1").Select

End Sub





わかお　かずまさ

VegaSystems


📷📷📷📷📷📷
#LAN_PRO
#Bloguru
#kuma
Share

People Who Wowed This Post

×
  • If you are a bloguru member, please login.
    Login
  • If you are not a bloguru member, you may request a free account here:
    Request Account
This user only allows bloguru members to make comments.
If you are a bloguru member, please login.
Login
If you are not a bloguru member, you may request a free account here:
Request Account