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