フォームのデザイン

<Global.Microsoft.VisualBasic.CompilerServices.DesignerGenerated()> _
Partial Class Form01_s
    Inherits System.Windows.Forms.Form

    'フォームがコンポーネントの一覧をクリーンアップするために dispose をオーバーライドします。
    <System.Diagnostics.DebuggerNonUserCode()> _
    Protected Overrides Sub Dispose(ByVal disposing As Boolean)
        Try
            If disposing AndAlso components IsNot Nothing Then
                components.Dispose()
            End If
        Finally
            MyBase.Dispose(disposing)
        End Try
    End Sub

    'Windows フォーム デザイナーで必要です。
    Private components As System.ComponentModel.IContainer

    'メモ: 以下のプロシージャは Windows フォーム デザイナーで必要です。
    'Windows フォーム デザイナーを使用して変更できます。  
    'コード エディターを使って変更しないでください。
    <System.Diagnostics.DebuggerStepThrough()> _
    Private Sub InitializeComponent()
        Me.Button1 = New System.Windows.Forms.Button()
        Me.Button2 = New System.Windows.Forms.Button()
        Me.SuspendLayout()
        '
        'Button1
        '
        Me.Button1.Location = New System.Drawing.Point(492, 12)
        Me.Button1.Name = "Button1"
        Me.Button1.Size = New System.Drawing.Size(219, 21)
        Me.Button1.TabIndex = 0
        Me.Button1.Text = "ガウスぼかし，高速画像処理"
        Me.Button1.UseVisualStyleBackColor = True
        '
        'Button2
        '
        Me.Button2.Location = New System.Drawing.Point(312, 146)
        Me.Button2.Name = "Button2"
        Me.Button2.Size = New System.Drawing.Size(75, 23)
        Me.Button2.TabIndex = 1
        Me.Button2.Text = "Button2"
        Me.Button2.UseVisualStyleBackColor = True
        '
        'Form01_s
        '
        Me.AutoScaleDimensions = New System.Drawing.SizeF(6.0!, 12.0!)
        Me.AutoScaleMode = System.Windows.Forms.AutoScaleMode.Font
        Me.ClientSize = New System.Drawing.Size(723, 466)
        Me.Controls.Add(Me.Button2)
        Me.Controls.Add(Me.Button1)
        Me.Name = "Form01_s"
        Me.Text = "Form2"
        Me.ResumeLayout(False)

    End Sub

    Friend WithEvents Button1 As Button
    Friend WithEvents Button2 As Button
End Class

my オンリーの書き方

Option Explicit

'このソフトのみの関数

'基本設定（出力先のシート名など）
Public Sub Standard_Set()

    
    Set ws_set = Worksheets("設定") '設定シート
    Set ws_Out = Worksheets(ws_set.Range("E1").Value) '出力シート
    Set non_Lock_rng = ws_Out.Range(ws_set.Range("E2").Value) 'シート保護なしセル
    Set ws_Select = Worksheets("プルダウン") '選択
    'Set ws_kata = Worksheets("型式") '型式
    Set ws_QR = Worksheets("QR") 'QR
    Set ws_hin = Worksheets("品名コード") '品名コード
 
    '設定シートの設定を参照
    ''入力
    Set ws_In = Worksheets(ws_set.Range("B1").Value) '入力シート
    StartRow = ws_set.Range("B2").Value  '入力欄の一番上の行
    dayCol = ws_set.Range("B3").Value  '列：日付
    kikaCol = ws_set.Range("B4").Value  '列：品名規格
    'denCol = ws_set.Range("B5").Value  '列：電流
    mekaCol = ws_set.Range("B6").Value  '列：メーカー
    nenCol = ws_set.Range("B7").Value  '列：製造年
    haiCol = ws_set.Range("B8").Value  '列：廃滅理由
    'ken1Col = ws_set.Range("B9").Value  '列：品名コードの検索値
    daiCol = ws_set.Range("B10").Value  '列：台数
    LimitRow = ws_set.Range("B11").Value '入力データ数の上限
    NoCol = ws_set.Range("B12").Value '列：No
    zaiCol = ws_set.Range("B13").Value '列：在庫種類
    'souCol = ws_set.Range("B14").Value '列：相線式
    keibangoCol = ws_set.Range("B15").Value '列：計器の番号
    kakuteiCol = ws_set.Range("B16").Value '列：確定
    str_kakutei = ws_set.Range("B17").Value '確定の表示
    bikoCol = ws_set.Range("B18").Value '列：備考

    '他
    str_Today = ws_set.Range("H1").Value '今日
    Set ws_Copy = Worksheets(ws_set.Range("H2").Value) 'シートコピーの元シート


    '入力されている中で最終行
    EndRow = Search_Data_EndRow()
    CountRow = EndRow - StartRow + 1 '入力のある行数

    '品名規格の分類
    hin_Grp(0) = "単独"
    hin_Grp(1) = "CT付"
    hin_Grp(2) = "VCT付"
    hin_Grp(3) = "その他"

End Sub

 

'集計
Public Sub Syukei()
 
    Dim i As Integer

    'カウントしたデータを入れる配列
    ReDim CountData_AllField(CountRow - 1, 6) As String    'キー配列(行数-1，項目数-1)： 各行に　要素7つ（品名規格，付く変, メーカー，製造年，廃滅理由，品名コード, 台数）
    ReDim CountData_HinCode(CountRow - 1, 3) As String    'キー配列(行数-1，項目数-1)： 各行に　要素4つ（品名規格，付く変, 品名コード,  台数）
    ReDim CountData_zai(CountRow - 1, 4) As String    'キー配列(行数-1，項目数-1)： 各行に　要素5つ（品名規格，付く変, 品名コード,  台数，在庫種類）


    '入力の集計
    For i = 0 To CountRow - 1 '入力行のループ
        Dim NowRow As Integer
        NowRow = StartRow + i
        Dim inputData1(6) As String '全項目
        Dim inputData2(3) As String '品目コード
        Dim inputData3(4) As String '在庫種類
        Dim n_himCode As String '品目コード
        Dim Add_hen As String '付く変:1単体 2CT 3VCT 4他
        Dim Disp_hin As String '表示用の品名規格
        Dim Search_Rng(3) As Range '検索セル
        Set Search_Rng(0) = Worksheets("品名コード").Range("A:A") '単体の品名コード
        Set Search_Rng(1) = Worksheets("品名コード").Range("D:D") 'CT
        Set Search_Rng(2) = Worksheets("品名コード").Range("G:G") 'VCT
        Set Search_Rng(3) = Worksheets("品名コード").Range("J:J") '他
        
        ''全項目
        inputData1(0) = ws_In.Cells(NowRow, kikaCol) '品名規格
        inputData1(2) = ws_In.Cells(NowRow, mekaCol) 'メーカー
        inputData1(3) = ws_In.Cells(NowRow, nenCol) '製造年
        inputData1(4) = ws_In.Cells(NowRow, haiCol) '廃滅理由
        '在庫種類
        inputData3(4) = ws_In.Cells(NowRow, zaiCol) '
        '
        If Get_himCode_hen(Search_Rng, ws_In.Cells(NowRow, kikaCol), n_himCode, Add_hen) = True Then '該当あり '品名コード，付く変:1単体 2CT 3VCT 4他
            inputData1(1) = Add_hen
            inputData1(5) = n_himCode
        Else
            inputData1(5) = "該当なし"
        End If
        inputData1(6) = ws_In.Cells(NowRow, daiCol) '台数
        
        ''品目コード
        inputData2(0) = inputData1(0) '品名規格
        inputData2(1) = inputData1(1) '付く変:1単体 2CT 3VCT 4他
        inputData2(2) = inputData1(5) '品名コード
        inputData2(3) = inputData1(6) '台数
        '在庫種類
        inputData3(0) = inputData2(0) '品名規格
        inputData3(1) = inputData2(1) '付く変:1単体 2CT 3VCT 4他
        inputData3(2) = inputData2(2) '品名コード
        inputData3(3) = inputData2(3) '台数
        
        '合致にカウントアップ，または，空項目に値を入れる
        Call CountUp1(CountData_AllField, inputData1) 'データ配列，入力配列(keyCol, inputData) 'データ配列，入力配列 '全項目
        Call CountUp2(CountData_HinCode, inputData2) '品目コード
        Call CountUp3(CountData_zai, inputData3) '在庫種類
       
    Next

End Sub


'合致にカウントアップ，または，空項目に値を入れる
Private Sub CountUp1(ByRef Arr() As String, inputData() As String)   'データ配列，入力配列

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer, yosoNo2 As Integer '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(Arr, 1)
    yosoNo2 = UBound(Arr, 2)
        
    '各要素の合致確認 '既にカウントされているものと同種は足し算の形でカウントアップ．異なる場合は新たな種類としてカウント開始
    For i = 0 To yosoNo1  '1次元目の要素数番号

        If (Arr(i, 0) = inputData(0) And Arr(i, 1) = inputData(1) And Arr(i, 2) = inputData(2) And Arr(i, 3) = inputData(3) And Arr(i, 4) = inputData(4) And Arr(i, 5) = inputData(5)) Then    '合致あり
            Arr(i, 6) = CStr(CInt(Arr(i, 6)) + CInt(inputData(6))) 'カウントアップ
            Exit Sub '終わり
        ElseIf Arr(i, 0) = "" Then '空
            For k = 0 To yosoNo2 '2次元目の要素番号
                Arr(i, k) = inputData(k) '入力データを入れる
            Next
            Exit Sub '終わり
        End If
    Next
End Sub
'品目コード
Private Sub CountUp2(ByRef Arr() As String, inputData() As String)   'データ配列，入力配列

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer, yosoNo2 As Integer '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(Arr, 1)
    yosoNo2 = UBound(Arr, 2)
    
    '各要素の合致確認 '既にカウントされているものと同種は足し算の形でカウントアップ．異なる場合は新たな種類としてカウント開始
    For i = 0 To yosoNo1  '1次元目の要素数番号

        If (Arr(i, 0) = inputData(0) And Arr(i, 1) = inputData(1) And Arr(i, 2) = inputData(2)) Then  '合致あり
            Arr(i, 3) = CStr(CInt(Arr(i, 3)) + CInt(inputData(3))) 'カウントアップ
            Exit Sub '終わり
        ElseIf Arr(i, 0) = "" Then    '全て空
            For k = 0 To yosoNo2 '2次元目の要素番号
                Arr(i, k) = inputData(k) '入力データを入れる
            Next
            Exit Sub '終わり
        End If
    Next
End Sub
'在庫種類
Private Sub CountUp3(ByRef Arr() As String, inputData() As String)   'データ配列，入力配列

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer, yosoNo2 As Integer '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(Arr, 1)
    yosoNo2 = UBound(Arr, 2)
    
    '各要素の合致確認 '既にカウントされているものと同種は足し算の形でカウントアップ．異なる場合は新たな種類としてカウント開始
    For i = 0 To yosoNo1  '1次元目の要素数番号

        If Arr(i, 0) = inputData(0) And Arr(i, 1) = inputData(1) And Arr(i, 2) = inputData(2) And Arr(i, 4) = inputData(4) Then   '合致あり
            Arr(i, 3) = CStr(CInt(Arr(i, 3)) + CInt(inputData(3))) 'カウントアップ
            Exit Sub '終わり
        ElseIf Arr(i, 0) = "" Then    '全て空
            For k = 0 To yosoNo2 '2次元目の要素番号
                Arr(i, k) = inputData(k) '入力データを入れる
            Next
            Exit Sub '終わり
        End If
    Next
End Sub

 

'セルにカウントした値を入れる
Public Sub CountInput(Arr() As String, rng As Range) '値，格納先

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer, yosoNo2 As Integer '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(Arr, 1)
    yosoNo2 = UBound(Arr, 2)
    
    '
    For i = 0 To yosoNo1 '1次元目の要素番号
        For k = 0 To yosoNo2 '2次元目の要素番号
            rng.Offset(i, k).Value = Arr(i, k)  'セルに記載
        Next
    Next
  
End Sub

'品名コードと変付き（1単体 2CT 3VCT 4他）を得る
Function Get_himCode_hen(Search_Rng() As Range, Search_text As String, ByRef ReCode As String, ByRef Rehen As String) As Boolean '探すセル(単体，CT，VCT）)，探す文字，返す値
    
    Dim i As Integer
    Dim yosoNo As Integer '最大要素番号
    yosoNo = UBound(Search_Rng)
    ReCode = ""
    Rehen = ""
    
    '品名コードを探す
    For i = 0 To yosoNo '最大要素番号
        If Search_Cell_Text(Search_Rng(i), Search_text, ReCode) = True Then '該当あり '品名コード
            Get_himCode_hen = True
            Select Case i
                Case 0
                    Rehen = "1" '単体
                Case 1
                    Rehen = "2" 'CT
                Case 2
                    Rehen = "3" 'VCT
                Case 3
                    Rehen = "4" '他
            End Select
            Exit Function '終わり
        End If
    Next
    
    '該当なし
    ReCode = "該当なし"
    Get_himCode_hen = False
    Exit Function '終わり
        
End Function
Function Search_Cell_Text(Search_Rng As Range, Search_text As String, ByRef ReCode1 As String) As Boolean '探すセル，探す文字，返す値(品名コード)
    Dim rng As Range
    ReCode1 = ""
      
    Set rng = Search_Rng.Find(Search_text)
    If rng Is Nothing Then
        Search_Cell_Text = False
    Else '該当あり
        ReCode1 = rng.Offset(0, 1).Value '右隣りのセルの値 '品名コード
        Search_Cell_Text = True
    End If
End Function

'ソートを使う
Function Sort_Use()

    ws_Out.Activate
    Call ws_Out.Range("BK14:DE111").Sort(Key1:=Range("DD14"), Order1:=xlAscending)
    Call ws_Out.Range("DJ14:DM111").Sort(Key1:=Range("DL14"), Order1:=xlAscending)

End Function

'カウントをcsvファイルデータ位置にする
Public Sub Arr_Change_CsvFormat(arr_all() As String, ByRef arr_csv() As String)

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer  '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(arr_all, 1) '行
    ReDim arr_csv(yosoNo1, 5) '6列

    
    '各要素の合致確認
    For i = 0 To yosoNo1  '1次元目の要素数番号 '行
        arr_csv(i, 0) = arr_all(i, 2) '品名コード
        arr_csv(i, 1) = "" 'メーカー名'なし
        arr_csv(i, 2) = "" 'メーカー名'なし
        arr_csv(i, 3) = "" 'メーカー名'なし
        arr_csv(i, 4) = "" 'メーカー名'なし
        arr_csv(i, 5) = arr_all(i, 3) 'カウント
    Next
    
End Sub

'入出庫システム用のQRの文字列にする
Public Sub Arr_Change_QRstr_Format(arr_all() As String, ByRef arr_QRstr As String)

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(arr_all, 1) '行

    arr_QRstr = ""
    
    '各要素の合致確認
    For i = 0 To yosoNo1  '1次元目の要素数番号 '行
        If arr_all(i, 2) <> "" Then '品名コードがある
            arr_QRstr = arr_QRstr & arr_all(i, 2)  '品名コード
            arr_QRstr = arr_QRstr & arr_all(i, 4) 'カウント
            arr_QRstr = arr_QRstr & vbTab  '入出庫システムへの入力QR用に，最後は次の行へ行くためのTab
        End If

    Next
    
End Sub

 

'カウントを付く変:1単体 2CT 3VCT 4他で分ける
Public Sub Get_PartData(arr_all() As String, ByRef arr_tan() As String, ByRef arr_CT() As String, ByRef arr_VCT() As String, ByRef arr_hoka() As String)

    Dim i As Integer, k As Integer
    Dim yosoNo1 As Integer, yosoNo2 As Integer '配列の要素番号の1次元目,2次元目
    
    yosoNo1 = UBound(arr_all, 1)
    yosoNo2 = UBound(arr_all, 2)
    ReDim arr_tan(yosoNo1, yosoNo2)
    ReDim arr_CT(yosoNo1, yosoNo2)
    ReDim arr_VCT(yosoNo1, yosoNo2)
    ReDim arr_hoka(yosoNo1, yosoNo2)
    
    '各要素の合致確認
    For i = 0 To yosoNo1  '1次元目の要素数番号 '行
        If arr_all(i, 1) = "1" Then   '単体
            For k = 0 To yosoNo2 '2次元目の要素番号'列
                arr_tan(i, k) = arr_all(i, k)  '入力データを入れる
            Next
        ElseIf arr_all(i, 1) = "2" Then   'CT付き
            For k = 0 To yosoNo2 '2次元目の要素番号'列
                arr_CT(i, k) = arr_all(i, k)  '入力データを入れる
            Next
        ElseIf arr_all(i, 1) = "3" Then   'VCT付き
            For k = 0 To yosoNo2 '2次元目の要素番号'列
                arr_VCT(i, k) = arr_all(i, k)  '入力データを入れる
            Next
        ElseIf arr_all(i, 1) = "4" Then   '4他
            For k = 0 To yosoNo2 '2次元目の要素番号'列
                arr_hoka(i, k) = arr_all(i, k)  '入力データを入れる
            Next
        End If
    Next
    
End Sub


'データの最終行を探す
Function Search_Data_EndRow()

    '入力されている中で最終行
    Dim n As Integer
    n = ws_In.Cells(65536, dayCol).End(xlUp).Row  '入力されている中で最終行
    If n < StartRow Then '最終行が最初の行より上
        n = StartRow
    End If
    
    Search_Data_EndRow = n '返り値
    
End Function

'データの未入力行を探す
Function Search_Data_NewRow()

    '入力されている中で最終行
    Search_Data_NewRow = ws_In.Cells(65536, dayCol).End(xlUp).Row + 1 '入力されている中で最終行
    
End Function


'QRボタン
Public Sub QR_btn_Function()
      
    Dim QR_tan As String '単体
    Dim QR_CT As String
    Dim QR_VCT As String
    Dim QR_hoka As String
    
    '集計ボタンの処理
    Call syuke_btn_Function

    'QRを書くところを初期化
     ws_QR.Cells.ClearContents


    'QRを作るため
    Call QR_Action(CountData_tan, 10)
    Call QR_Action(CountData_CT, 90)
    Call QR_Action(CountData_VCT, 170)
    Call QR_Action(CountData_hoka, 250)

    'カウントをcsvファイルデータ位置にする
    'Call Arr_Change_QRstr_Format(CountData_tan, QR_tan)
    'Call Arr_Change_QRstr_Format(CountData_CT, QR_CT)
    'Call Arr_Change_QRstr_Format(CountData_VCT, QR_VCT)
    'Call Arr_Change_QRstr_Format(CountData_hoka, QR_hoka)
        
        
     'Call textQR(ws_QR, 10, 10, QR_tan)
     'Call textQR(ws_QR, 90, 90, QR_CT)
     'Call textQR(ws_QR, 170, 170, QR_VCT)
     'Call textQR(ws_QR, 250, 90, QR_hoka)
     
End Sub

'CSVボタン
Public Sub CSV_btn_Function()

    '集計ボタンの処理
    Call syuke_btn_Function
    
    'CSVを作るため
    Call CSV_Action(CountData_tan, "単体")
    Call CSV_Action(CountData_CT, "CT付き")
    Call CSV_Action(CountData_VCT, "VCT付き")
    Call CSV_Action(CountData_hoka, "他")
    
    'カウントをcsvファイルデータ位置にする
    'Call Arr_Change_CsvFormat(CountData_tan, csv_tan)
    'Call Arr_Change_CsvFormat(CountData_CT, csv_CT)
    'Call Arr_Change_CsvFormat(CountData_VCT, csv_VCT)
    'Call Arr_Change_CsvFormat(CountData_hoka, csv_hoka)
    
    '
    'Call csv_Dialog(csv_tan, "単体_規定の名称.csv")
    'Call csv_Dialog(csv_CT, "CT付き_規定の名称.csv")
    'Call csv_Dialog(csv_VCT, "VCT付き_規定の名称.csv")
    'Call csv_Dialog(csv_VCT, "他_規定の名称.csv")

     
End Sub


'集計ボタンの処理
Public Sub syuke_btn_Function()

    'このブックの基本設定（出力先のシート名など）
    Call Standard_Set

    'QRを書くところを初期化
     ws_QR.Cells.ClearContents

    '集計
    Call Syukei
    
    'セルにカウントした値を入れる
    ws_Out.Unprotect 'シート保護解除
    ws_Out.Range("CY14:DM115").Clear 'クリア
    Call CountInput(CountData_AllField, ws_Out.Cells(14, "CY"))
    Call CountInput(CountData_HinCode, ws_Out.Cells(14, "DJ"))
    Call CountInput(CountData_zai, ws_Out.Cells(14, "DQ"))
    Call Get_PartData(CountData_zai, CountData_tan, CountData_CT, CountData_VCT, CountData_hoka) 'カウントを付く変:1単体 2CT 3VCT 4他で分ける
    
    'ソートを使う
    Call Sort_Use

    ws_Out.Cells(6, "AT") = str_Today   '日付を記載  '今日

    non_Lock_rng.Locked = False '一部ロックしない
    ws_Out.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 'シート保護
    
    ActiveWorkbook.Save 'ブック上書き保存
    

End Sub

 

'コピーを新規の別シートへ出力
Public Sub Copy_OutPut(OutSheetName As String)
   
    ws_Copy.Visible = True '表示 コピー元

    ws_Copy.Select
    ws_Copy.Copy After:=ws_Copy ' コピー
    ActiveSheet.name = OutSheetName 'シート名変更
    ActiveSheet.Range("B6:BN109").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False '他のシートの値を表示しているところを，値のみコピーで上書きして固定値にする
    ActiveSheet.Range("B6").Select
    
    ws_Copy.Visible = False '非表示
    
    'MsgBox "コピーしました"

End Sub

 

'コピー出力ボタン
Public Sub Copy_Out_btn_Function()

    Dim rc As Integer
    rc = MsgBox("コピー出力しますか？（元のデータは削除されます）", vbYesNo + vbExclamation + vbDefaultButton2, "コピー出力")
    If rc = vbYes Then 'はい
        '
    Else 'いいえ
        MsgBox "キャンセルしました"
        Exit Sub
    End If

    'このブックの基本設定（出力先のシート名など）
    Call Standard_Set
    
    '作成するシート名が既にある場合，作業済みとして止める
    Dim OutSheetName As String '出力先シート名
    OutSheetName = Format(Date, "yyyy.mm.dd")  ' 今日の日付を取得
    Dim ws As Worksheet
    For Each ws In Worksheets  '作成するシート名が既にある場合，作業済みとして止める
        If ws.name = OutSheetName Then
            MsgBox "シート「" & OutSheetName & "」は作成済みです"
            Exit Sub
        End If
    Next
    
    '待ち画面
    Form_wait.Show vbModeless
    
    '画面更新の非表示
    'Application.ScreenUpdating = False
    
    '集計ボタンの処理 '入力後に，集計していない場合を想定して，強制的に集計します（コピー出力したデータの入力と集計の不整合防止）
    Call syuke_btn_Function
    
    'コピーを新規の別シートへ出力
    Call Copy_OutPut(OutSheetName)

    '入力消す
    Call input_kesu
    
    
    '集計ボタンの処理 '削除した入力を元に集計して，疑似的に集計の削除を実現させます
    Call syuke_btn_Function
    
    '画面更新の非表示 の解除
    'Application.ScreenUpdating = True
 
    '待ち画面 '閉じる
    Unload Form_wait
    
    '出力したシート
    Worksheets(OutSheetName).Select
    
    MsgBox "コピー出力しました"
    

    
End Sub


'入力消す
Public Sub input_kesu()

    'このブックの基本設定（出力先のシート名など）
    Call Standard_Set

    Dim i As Integer
    Dim n_Last As Integer
    n_Last = StartRow + LimitRow '入力データ数の上限
    ws_In.Unprotect 'シート保護解除
    For i = StartRow To n_Last
        ws_In.Cells(i, dayCol) = ""  '日付
        ws_In.Cells(i, kakuteiCol) = ""
        '色
        ws_In.Cells(i, zaiCol).Interior.ColorIndex = 2 '白色   '在庫種類
        ws_In.Cells(i, mekaCol).Interior.ColorIndex = 2
        ws_In.Cells(i, kikaCol).Interior.ColorIndex = 2
        ws_In.Cells(i, keibangoCol).Interior.ColorIndex = 2
        ws_In.Cells(i, nenCol).Interior.ColorIndex = 2
        ws_In.Cells(i, haiCol).Interior.ColorIndex = 2
        ws_In.Cells(i, daiCol).Interior.ColorIndex = 2
        ws_In.Cells(i, bikoCol).Interior.ColorIndex = 2
        ws_In.Cells(i, kakuteiCol).Interior.ColorIndex = 2
        ws_In.Cells(i, dayCol).Interior.ColorIndex = 2
        ws_In.Cells(i, NoCol).Interior.ColorIndex = 2
    
        '文字
        ws_In.Cells(i, zaiCol) = ""   '在庫種類
        ws_In.Cells(i, mekaCol) = ""  'メーカー
        ws_In.Cells(i, kikaCol) = "" '品名規格
        ws_In.Cells(i, keibangoCol) = ""  '計器の番号
        ws_In.Cells(i, nenCol) = ""    '年製
        ws_In.Cells(i, haiCol) = "" '不良原因 廃滅理由
        ws_In.Cells(i, daiCol) = ""   '台数
        ws_In.Cells(i, bikoCol) = ""   '備考
    Next
    ws_In.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 'シート保護
        
End Sub


'データ削除 '一つ下の行の値を，消す行に上書きすることで消す，それを最終行まで繰り返して1行ずつ繰り上げていく
Public Sub Row_kesu(Row_n As Integer) '消す行


    'このブックの基本設定（出力先のシート名など）
    Call Standard_Set

    Dim i As Integer
    Dim n_Last As Integer

    Dim text_n As String
    'Dim Row_n As Integer
    Dim rc As Integer


    Dim Row_s As Integer
    Row_s = Row_n + 1 '消す行の1つ下の行から始める


    n_Last = StartRow + LimitRow '入力データ数の上限
    ws_In.Unprotect 'シート保護解除
    For i = Row_s To n_Last
        '一つ下の行の値を，消す行に上書きすることで消す，それを最終行まで繰り返して1行ずつ繰り上げていく
        ws_In.Cells(i - 1, dayCol) = ws_In.Cells(i, dayCol) '日付
        ws_In.Cells(i - 1, kakuteiCol) = ws_In.Cells(i, kakuteiCol)
        ws_In.Cells(i - 1, zaiCol) = ws_In.Cells(i, zaiCol)   '在庫種類
        ws_In.Cells(i - 1, mekaCol) = ws_In.Cells(i, mekaCol)  'メーカー
        ws_In.Cells(i - 1, kikaCol) = ws_In.Cells(i, kikaCol) '品名規格
        ws_In.Cells(i - 1, keibangoCol) = ws_In.Cells(i, keibangoCol)  '計器の番号
        ws_In.Cells(i - 1, nenCol) = ws_In.Cells(i, nenCol)    '年製
        ws_In.Cells(i - 1, haiCol) = ws_In.Cells(i, haiCol) '不良原因 廃滅理由
        ws_In.Cells(i - 1, daiCol) = ws_In.Cells(i, daiCol)   '台数
        ws_In.Cells(i - 1, bikoCol) = ws_In.Cells(i, bikoCol)   '備考
        
        '形式コピー
        ws_In.Cells(i, NoCol).Copy
        ws_In.Cells(i - 1, NoCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, dayCol).Copy
        ws_In.Cells(i - 1, dayCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, kakuteiCol).Copy
        ws_In.Cells(i - 1, kakuteiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, zaiCol).Copy
        ws_In.Cells(i - 1, zaiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, mekaCol).Copy
        ws_In.Cells(i - 1, mekaCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, kikaCol).Copy
        ws_In.Cells(i - 1, kikaCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, keibangoCol).Copy
        ws_In.Cells(i - 1, keibangoCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, nenCol).Copy
        ws_In.Cells(i - 1, nenCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, haiCol).Copy
        ws_In.Cells(i - 1, haiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, daiCol).Copy
        ws_In.Cells(i - 1, daiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, bikoCol).Copy
        ws_In.Cells(i - 1, bikoCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        
    Next
    ws_In.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 'シート保護
        

 

End Sub


'在庫種類で絞り込む
Function zai_Filter(n_arr() As String, n_Filter As String) As String() '在庫種類で絞り込む

    Dim i As Integer, k As Integer, p As Integer
    Dim yosoNo1 As Integer  '配列の要素番号の1次元目
    Dim yosoNo2 As Integer
    Dim Re_arr() As String
    
    
    yosoNo1 = UBound(n_arr, 1) '行
    yosoNo2 = UBound(n_arr, 2)
    
    ReDim Re_arr(yosoNo1, yosoNo2)
    
    p = 0

    
        '各要素の合致確認 '既にカウントされているものと同種は足し算の形でカウントアップ．異なる場合は新たな種類としてカウント開始
    For i = 0 To yosoNo1  '1次元目の要素数番号
        If n_arr(i, 4) = n_Filter Then
            For k = 0 To yosoNo2 '2次元目の要素番号
                Re_arr(p, k) = n_arr(i, k) '入力データを入れる
            Next
            p = p + 1
        End If
    Next
    
    zai_Filter = Re_arr
    
End Function

 

'CSVを作るため
Public Sub CSV_Action(n_CountData() As String, n_Name As String) 'csvに書くデータのもと，ファイル名

    Dim nnn() As String
    Dim ppp() As String
    Dim n_add As String
    Dim i As Integer
    
    For i = 1 To 100
        n_add = ws_Select.Cells(i, "A") '在庫種類プルダウン
        If n_add <> "" Then '空でない
            '在庫種類で絞り込む
            nnn = zai_Filter(n_CountData, n_add) '在庫種類で絞り込む
            If nnn(0, 0) = "" Then 'データなし
                MsgBox "「" & n_Name & "-" & n_add & "」は，データがありませんのでファイルを作りません"
            Else
                Call Arr_Change_CsvFormat(nnn, ppp)
                Call csv_Dialog(ppp, n_Name & "_" & n_add & ".csv")
            End If
        Else
            i = 100 '終わり
        End If
    Next
        

End Sub

'QRを作るため
Public Sub QR_Action(n_CountData() As String, n_iti As Integer) 'csvに書くデータのもと，縦位置

    Dim nnn() As String
    Dim ppp As String
    Dim n_add As String
    Dim i As Integer
    
    For i = 1 To 100
        n_add = ws_Select.Cells(i, "A") '在庫種類プルダウン
        If n_add <> "" Then '空でない
            '在庫種類で絞り込む
            nnn = zai_Filter(n_CountData, n_add) '在庫種類で絞り込む
            If nnn(0, 0) = "" Then 'データなし
                'MsgBox "「" & n_Name & "-" & n_add & "」は，データがありませんのでファイルを作りません"
            Else
                Call Arr_Change_QRstr_Format(nnn, ppp)
                Call textQR(ws_QR, 10 + (i - 1) * 80, n_iti, ppp)
            End If
        Else
            i = 100 '終わり
        End If
    Next
        
        
        
             'Call textQR(ws_QR, 10, 10, QR_tan)
     'Call textQR(ws_QR, 90, 90, QR_CT)
     'Call textQR(ws_QR, 170, 170, QR_VCT)
     'Call textQR(ws_QR, 250, 90, QR_hoka)
        

End Sub

 

変数はこう書くよ

'変数設定

Public CountData_AllField() As String '入力カウント '全項目のカウント
Public CountData_HinCode() As String '入力カウント '品目コード毎のカウント
Public CountData_zai() As String '入力カウント '在庫種類と品目コード毎のカウント
Public CountData_tan() As String '入力カウント '単体
Public CountData_CT() As String '入力カウント 'CT付き
Public CountData_VCT() As String '入力カウント 'VCT付き
Public CountData_hoka() As String '入力カウント '他

消すボタンはこうかくよ


'データ削除ボタン
Private Sub btn_kesu_Click()

    Dim text_n As String
    Dim Row_n As Integer
    Dim rc As Integer

    '選択行の取得
    Row_n = Get_Select_Row()
    
    'メッセージ
    text_n = text_n & "下記のデータを削除しますか？" & vbCrLf & vbCrLf
    
    text_n = text_n & "No：" & ws_In.Cells(Row_n, NoCol) & vbCrLf
    text_n = text_n & "日付：" & ws_In.Cells(Row_n, dayCol) & vbCrLf
    text_n = text_n & "在庫種類：" & ws_In.Cells(Row_n, zaiCol) & vbCrLf
    text_n = text_n & "メーカー：" & ws_In.Cells(Row_n, mekaCol) & vbCrLf
    text_n = text_n & "品名規格：" & ws_In.Cells(Row_n, kikaCol) & vbCrLf
    text_n = text_n & "計器の番号：" & ws_In.Cells(Row_n, keibangoCol) & vbCrLf
    text_n = text_n & "年製：" & ws_In.Cells(Row_n, nenCol) & vbCrLf
    text_n = text_n & "廃滅理由：" & ws_In.Cells(Row_n, haiCol) & vbCrLf
    text_n = text_n & "台数：" & ws_In.Cells(Row_n, daiCol) & vbCrLf

    rc = MsgBox(text_n, vbYesNo + vbExclamation + vbDefaultButton2, "データ削除")
    If rc = vbYes Then 'はい
        'データ削除 '一つ下の行の値を，消す行に上書きすることで消す，それを最終行まで繰り返して1行ずつ繰り上げていく
        Row_kesu (Row_n) '消す行
        MsgBox "削除しました"
    Else 'いいえ
        MsgBox "キャンセルしました"
        Exit Sub
    End If


End Sub

1行消して繰り上げるには　　No１００より下に書式を用意しよう


'データ削除 '一つ下の行の値を，消す行に上書きすることで消す，それを最終行まで繰り返して1行ずつ繰り上げていく
Public Sub Row_kesu(Row_n As Integer) '消す行


    'このブックの基本設定（出力先のシート名など）
    Call Standard_Set

    Dim i As Integer
    Dim n_Last As Integer

    Dim text_n As String
    'Dim Row_n As Integer
    Dim rc As Integer


    Dim Row_s As Integer
    Row_s = Row_n + 1 '消す行の1つ下の行から始める


    n_Last = StartRow + LimitRow '入力データ数の上限
    ws_In.Unprotect 'シート保護解除
    For i = Row_s To n_Last
        '一つ下の行の値を，消す行に上書きすることで消す，それを最終行まで繰り返して1行ずつ繰り上げていく
        ws_In.Cells(i - 1, dayCol) = ws_In.Cells(i, dayCol) '日付
        ws_In.Cells(i - 1, kakuteiCol) = ws_In.Cells(i, kakuteiCol)
        ws_In.Cells(i - 1, zaiCol) = ws_In.Cells(i, zaiCol)   '在庫種類
        ws_In.Cells(i - 1, mekaCol) = ws_In.Cells(i, mekaCol)  'メーカー
        ws_In.Cells(i - 1, kikaCol) = ws_In.Cells(i, kikaCol) '品名規格
        ws_In.Cells(i - 1, keibangoCol) = ws_In.Cells(i, keibangoCol)  '計器の番号
        ws_In.Cells(i - 1, nenCol) = ws_In.Cells(i, nenCol)    '年製
        ws_In.Cells(i - 1, haiCol) = ws_In.Cells(i, haiCol) '不良原因 廃滅理由
        ws_In.Cells(i - 1, daiCol) = ws_In.Cells(i, daiCol)   '台数
        ws_In.Cells(i - 1, bikoCol) = ws_In.Cells(i, bikoCol)   '備考
        
        '形式コピー
        ws_In.Cells(i, NoCol).Copy
        ws_In.Cells(i - 1, NoCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, dayCol).Copy
        ws_In.Cells(i - 1, dayCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, kakuteiCol).Copy
        ws_In.Cells(i - 1, kakuteiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, zaiCol).Copy
        ws_In.Cells(i - 1, zaiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, mekaCol).Copy
        ws_In.Cells(i - 1, mekaCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, kikaCol).Copy
        ws_In.Cells(i - 1, kikaCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, keibangoCol).Copy
        ws_In.Cells(i - 1, keibangoCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, nenCol).Copy
        ws_In.Cells(i - 1, nenCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, haiCol).Copy
        ws_In.Cells(i - 1, haiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, daiCol).Copy
        ws_In.Cells(i - 1, daiCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ws_In.Cells(i, bikoCol).Copy
        ws_In.Cells(i - 1, bikoCol).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
        
    Next
    ws_In.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True 'シート保護
        

 

End Sub