④Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub CreateQrcode()
'開始行
Dim firstRow As Long: firstRow = 3
'最終行の取得
Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row
'firstRow～lastRowまで繰り返し(途中エラーが出た場合も止めずに最後まで処理)
On Error Resume Next
For i = firstRow To lastRow
'QRコード表示セルの高さなどを調整
With Cells(i, "B")
.RowHeight = 65
.VerticalAlignment = xlTop '上詰め
End With
'GoogleAPIでQRコードを作成
Set qr = ActiveSheet.Pictures _
.Insert("http://chart.apis.google.com/chart?cht=qr&chs=80x80&chl=" _
+ Cells(i, "A").Value)
'QRコードの表示位置を指定
With qr
.Top = Cells(i, "B").Top + 2
.Left = Cells(i, "B").Left + 2
End With
Next i
On Error GoTo 0
End Sub
④ Microsoft Visual Basic for Applications」にて以下のコードを記載
Sub FunctionDisplayOnDeletion()
Dim searchValueRow As Integer: searchValueRow = 1 '★検索値列
Dim startFuncRow As Integer: startFuncRow = 2 '★VLOOKUP関数設定開始行
Dim startFuncCol As Integer: startFuncCol = 2 '★VLOOKUP関数設定開始列
Dim endFuncCol As Integer: endFuncCol = 3 '★VLOOKUP関数設定終了列
Dim c As Range, i As Long
For Each c In Selection
If c.Row >= startFuncRow _
And c.Column >= startFuncCol _
And c.Column <= endFuncCol Then
c.Value = "=IFERROR(VLOOKUP(" & Cells(c.Row, searchValueRow).Address(False, False) & ",品目情報!$A$2:$C$5," & c.Column & ",FALSE),"""")"
Else
c.Value = ""
End If
Next c
End Sub
Sub AutoActivateSheet_Name()
'DeleteKeyを押すと「FunctionDisplayOnDeletion」マクロ実行
Application.OnKey "{Delete}", "FunctionDisplayOnDeletion"
Application.OnKey "^{Delete}", "FunctionDisplayOnDeletion"
End Sub
Sub AutoDeactivateSheet_Name()
'DeleteKeyへの割り当て解除
Application.OnKey "{Delete}"
Application.OnKey "^{Delete}"
End Sub
Sub Auto_Open()
'「見積り入力」シートがアクティブになったら「AutoActivateSheet_Name」マクロ実行
Worksheets("見積り入力").OnSheetActivate = "AutoActivateSheet_Name"
'「見積り入力卸」シート以外がアクティブになったら「AutoDeactivateSheet_Name」マクロ実行
Worksheets("見積り入力").OnSheetDeactivate = "AutoDeactivateSheet_Name"
End Sub
③ 「Alt + F8」を押して表示される以下の画面で「マクロ名」を「SearchGoods_InputInventoryQuantity」として「作成」を押す
④ Microsoft Visual Basic for Applications」にて以下のコードを記載
Public enterFlg As Boolean
Sub SearchGoods_InputInventoryQuantity()
'検索文字入力行・列
Dim searchValueRow As Integer: searchValueRow = 1 '★
Dim searchValueCol As Integer: searchValueCol = 2 '★
'検索対象列
Dim searchTargetCol As Integer: searchTargetCol = 2 '★
'検索文字'
Dim searchValue As String: searchValue = Cells(searchValueRow, searchValueCol).Value
'棚卸数量入力行・列
Dim inventoryQuantityRow As Integer: inventoryQuantityRow = 2 '★
Dim inventoryQuantityCol As Integer: inventoryQuantityCol = 2 '★
'棚卸数量転記対象列
Dim copyQuantityTargetCol As Integer: copyQuantityTargetCol = 8 '★
'商品コード未入力メッセージ'
Dim codeNotEnteredMessage As String: codeNotEnteredMessage = "商品コードを入力してください" '★
'重複メッセージ'
Dim duplicateMessage As String: duplicateMessage = "既に入力があります" '★
'開始行
Dim startRow As Integer: startRow = 5 '★
'終了行
Dim lastRow As Integer: lastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
'アクティブCellが商品コードまたは棚卸数量欄でなければアクティブセルの移動のみ
Dim activeRow As Integer: activeRow = ActiveCell.Row
Dim activeCol As Integer: activeCol = ActiveCell.Column
'商品コード検索
If activeRow = searchValueRow And activeCol = searchValueCol Then
For i = startRow To lastRow Step 1
If Cells(i, searchTargetCol).Value <> searchValue And searchValue <> "" Then
Rows(i).Hidden = True
Else
Rows(i).Hidden = False
End If
Next
Cells(activeRow + 1, activeCol).Select
'棚卸数量入力(1回目)
ElseIf activeRow = inventoryQuantityRow And activeCol = inventoryQuantityCol And enterFlg = False And Cells(inventoryQuantityRow, inventoryQuantityCol) <> "" Then
If Cells(searchValueRow, searchValueCol).Value = "" Then
MsgBox codeNotEnteredMessage
Cells(searchValueRow, searchValueCol).Select
Exit Sub
End If
For i = startRow To lastRow Step 1
If Cells(i, copyQuantityTargetCol).Value = "" And Rows(i).Hidden = False Then
Cells(i, copyQuantityTargetCol).Value = Cells(inventoryQuantityRow, inventoryQuantityCol)
ElseIf Cells(i, copyQuantityTargetCol).Value <> "" And Rows(i).Hidden = False Then
MsgBox duplicateMessage
Exit Sub
End If
Next
enterFlg = True
'棚卸数量入力(2回目)
ElseIf activeRow = inventoryQuantityRow And activeCol = inventoryQuantityCol Then
For i = startRow To lastRow Step 1
Rows(i).Hidden = False
Next
Cells(inventoryQuantityRow, inventoryQuantityCol) = ""
Cells(searchValueRow, searchValueCol).Select
enterFlg = False
Else
Cells(activeRow + 1, activeCol).Select
Exit Sub
End If
End Sub
Sub Auto_Open()
'「実地棚卸」シートがアクティブになったら「AutoActivateSheet_Name」マクロ実行
Worksheets("実地棚卸").OnSheetActivate = "AutoActivateSheet_Name"
'「実地棚卸」シート以外がアクティブになったら「AutoDeactivateSheet_Name」マクロ実行
Worksheets("実地棚卸").OnSheetDeactivate = "AutoDeactivateSheet_Name"
End Sub
Sub AutoActivateSheet_Name()
'Enterを押すと「SearchGoods_InputInventoryQuantity」マクロ実行
Application.OnKey "~", "SearchGoods_InputInventoryQuantity"
Application.OnKey "{Enter}", "SearchGoods_InputInventoryQuantity"
End Sub
Sub AutoDeactivateSheet_Name()
'テンキーのEnterへの割り当て解除
Application.OnKey "{Enter}"
'大きいEnterへの割り当て解除
Application.OnKey "~"
End Sub
⑤「Microsoft Visual Basic for Applications」にて以下のコードを記載
必要に応じて「★」のついた箇所を変更
Sub Addup_Click()
Call ReadCSV
End Sub
Function ReadCSV()
'★読み込み対象ファイルの絶対パスを指定
Dim filePass As String: filePass = "C:\SalesData.csv"
'★書き込みを開始する行・列を指定
Dim startRow As Integer: startRow = 2
Dim startCol As Integer: startCol = 1
'★定期実行する間隔を指定
Dim waitSec As Single: waitSec = 5
Dim targetRow As Integer: targetRow = startRow
Dim targetCol As Integer: targetCol = startCol
Dim rowBuf As String
Dim cellBufList As Variant
Open filePass For Input As #1
'全行読み込み終わるまで繰り返し
Do Until EOF(1)
'１行読み込み
Line Input #1, rowBuf
'読みこんだ１行をカンマで区切り配列化
cellBufList = Split(rowBuf, ",")
'配列分繰り返し
For Each cellBuf In cellBufList
Cells(targetRow, targetCol).Value = cellBuf
'次の列へ
targetCol = targetCol + 1
Next cellBuf
'次の行へ
targetCol = startCol
targetRow = targetRow + 1
Loop
Close #1
'ピボットテーブルの更新
Dim pvt As PivotTable
For Each pvt In ActiveSheet.PivotTables
pvt.PivotCache.Refresh
Next
'待機処理
Dim Tm As Single
Tm = Timer
Do
DoEvents
Loop Until Timer > Tm + waitSec
'再帰
Call ReadCSV
End Function
