投稿日:

【Excel】CSVファイルをリアルタイム読み取り

VBAを利用して、随時更新されるcsvファイルをリアルタイムで読み取るプログラムを作成しました。
随時更新される売上データを題材に作成しています。

Icon

csvReadImmediately.zip

1 file(s) 34.90 KB
エクセルファイルをダウンロード

このエクセルファイルの作り方

①マクロを使えるようにする

「マクロを使えるようにする」を参照

②元データとするCSVファイルを用意

③読み取ったCSVを書き込むテーブルを作成

④テーブルの値を集計する任意のピボットグラフを作成

⑤集計開始をするボタンを用意

※ボタンの追加方法は「以前の記事」を参考

⑥マクロを作成する

ボタン配置時の以下の画面で「マクロ名」を「Addup_Click」として「新規作成」を押す

⑤「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

投稿日:

【Excel】ビンゴゲームを作る

Icon

bingo.zip

1 file(s) 22.17 KB
エクセルファイルをダウンロード

 

このエクセルファイルの作り方

①ビンゴゲームのレイアウトを作成する

・A1:L16 ⇒ ビンゴの数字表示欄
・M2:Q16 ⇒ ビンゴで出た数字の背景色を緑色で表示
・「BINGO」ボタン ⇒ ルーレットを開始して「A1:L16」に数字を表示
・「Initialize」ボタン ⇒ 初期化
※各ボタン配置時に設定するマクロ名はそれぞれ「Bingo」、「Initialize」とする

②Microsoft Visual Basic for Applications」にて以下のコードを記載

Sub Bingo()
'結果
Dim result As Integer
'(これまでに出た)結果リスト
Dim resultList As Variant: resultList = Range("A21:A95")

'1～75まで全て出ている場合はなにもしない
If (IsEmpty(Range("A95").Value) = False) Then
GoTo PROCESSINGEXIT
End If

'ボタンを配置したセルを選択する
Cells(1, 13).Select

'フォントサイズを設定
Worksheets("BINGO").Range("A2").Font.Size = 350

'ルーレット表示
For i = 1 To 100
Application.Wait [Now()] + 5 / 86400000
result = Int(75 * Rnd + 1)
Worksheets("BINGO").Range("A2").Value = result
Next

'重複制御
Do While (1)
result = Int(75 * Rnd + 1)
For i = 1 To UBound(resultList)
If (resultList(i, 1) = result) Then
GoTo BREAK
End If
Next
Exit Do
BREAK:
Loop
Worksheets("BINGO").Range("A2").Value = result

'結果書き込み
For i = 1 To UBound(resultList)
If (IsEmpty(Cells(i + 20, 1).Value) = True) Then
Cells(i + 20, 1).Value = result
Exit For
Else
GoTo CONTINUE
End If
CONTINUE:
Next

PROCESSINGEXIT:

End Sub

Sub Initialize()
Range("A21:A95").ClearContents<img src="https://exceldemon.net/wp-content/uploads/2018/11/条件付き書式.png" alt="" width="379" height="396" class="alignnone size-full wp-image-432" />
Worksheets("BINGO").Range("A2").Font.Size = 15
Worksheets("BINGO").Range("A2").Value = "Please press ""BINGO"" button"
End Sub

③条件付き書式を設定

※すでに出た数値の背景色を緑色とする

プログラムの解説

'ルーレット表示
For i = 1 To 100
Application.Wait [Now()] + 5 / 86400000
result = Int(75 * Rnd + 1)
Worksheets("BINGO").Range("A2").Value = result
Next

100回ループさせ、「Application.Wait [Now()] + 5 / 86400000」の記載で5ミリ秒ごと1～75のランダムな数値を表示

'重複制御
Do While (1)
result = Int(75 * Rnd + 1)
For i = 1 To UBound(resultList)
If (resultList(i, 1) = result) Then
GoTo BREAK
End If
Next
Exit Do
BREAK:
Loop
Worksheets("BINGO").Range("A2").Value = result

「Do While (1)」で無限ループを発生。
「result = Int(75 * Rnd + 1)」でresultに1～75のランダムな数値を格納する。

「For i = 1 To UBound(resultList)～Next」でresultList分ループし、
resultListにresultの数値がすでに含まれている場合はBREAKして再度1～75のランダムな数値を格納し直す。
含まれていない数値だった場合は「Exit Do」でループを抜けて、「A2」にresultの数値をセット。

'結果書き込み
For i = 1 To UBound(resultList)
If (IsEmpty(Cells(i + 20, 1).Value) = True) Then
Cells(i + 20, 1).Value = result
Exit For
Else
GoTo CONTINUE
End If
CONTINUE:
Next

「For i = 1 To UBound(resultList)～Next」でresultList分ループし、
値が入っていないCellまで来たら今回Resultに格納している数値を書き込む

Sub Initialize()
Range("A21:A95").ClearContents
Worksheets("BINGO").Range("A2").Font.Size = 15
Worksheets("BINGO").Range("A2").Value = "Please press ""BINGO"" button"
End Sub

「Range(“A21:A95”).ClearContents」で背景色が緑色になったところを元に戻す。
初期のフォントサイズと初期値を設定。

投稿日:

【Excel】インクリメントしたシート名を追加する

Sub Test()
Dim resultSheetName As String: resultSheetName = "テスト結果" '基本となるシート名
Dim newSheetName As String: newSheetName = resultSheetName '動的に変化するシート名
Dim count As Integer: count = 1

Dim ws As Worksheet
'全てのシートを走査し、同じシート名が存在する場合はcountを加算してnewSheetNameを更新
For Each ws In Worksheets
If ws.Name = newSheetName Then
count = count + 1
newSheetName = resultSheetName & "(" & CStr(count) & ")"
End If
Next ws

'シート追加及び名称変更
Dim newWorksheet As Worksheet: Set newWorksheet _
= Worksheets.Add(After:=Sheets(Worksheets.count))
newWorksheet.Name = newSheetName

'Testシートに戻る
Sheets("Test").Select
End Sub
投稿日:

【Excel】指定した数だけデータをコピーする

①コピー元シートを用意
※ここでは「表を複数の条件で絞り込む②」で作成したシートを使用(数量列だけ追加)

②ペーストするシートを用意

③コピーを実行するボタンを配置

④ボタン配置時の以下の画面で「マクロ名」を「CreateLabelData」として「新規作成」を押す

⑤「Microsoft Visual Basic for Applications」にて以下のコードを記載
※表の形式に応じて「★」のついた箇所の数値を変更

Sub CreateLabelData()
'コピー開始行
Dim copyStartRow As Integer: copyStartRow = 5 '★
'コピー最終行
Dim copyLastRow As Integer: copyLastRow = ActiveSheet.UsedRange.Row + ActiveSheet.UsedRange.Rows.Count - 1
'コピー開始列
Dim copyStartCol As Integer: copyStartCol = 2 '★
'コピー終了列
Dim copyLastCol As Integer: copyLastCol = 4 '★
'数量列
Dim quantityCol As Integer: quantityCol = 5 '★

'ペーストするシート名
Dim pasteSheetName As String: pasteSheetName = "商品ラベルデータ" '★
'ペースト行
Dim pasteRow As Integer: pasteRow = 2 '★
'ペースト列
Dim pasteCol As Integer: pasteCol = 1 '★
'ペーストするシートの最終行
pasteLastRow = Worksheets(pasteSheetName).UsedRange.Row + Worksheets(pasteSheetName).UsedRange.Rows.Count - 1

'ペーストするシートの初期化
For i = pasteRow To pasteLastRow Step 1
Worksheets(pasteSheetName).Rows(pasteRow).Delete
Next

'コピー開始行から終了行までループ
For i = copyStartRow To copyLastRow Step 1
'数量の指定が不正な場合は次の行へ
If Cells(i, quantityCol).Formula = "" Or IsNumeric(Cells(i, quantityCol).Value) = False Or Cells(i, quantityCol).Value < 1 Then
GoTo Continue
Else
End If

'対象行の数量を取得
Dim quantity As Integer: quantity = Cells(i, quantityCol).Value

'数量分コピー&ペーストを行う
For j = pasteRow To pasteRow + quantity - 1 Step 1
Range(Cells(i, copyStartCol), Cells(i, copyLastCol)).Copy Destination:=Worksheets(pasteSheetName).Cells(j, pasteCol)
Next

'次回ペースト行の更新
pasteRow = pasteRow + quantity

'数量の値を初期化
Cells(i, quantityCol).Value = ""
Continue:
Next

'ペーストしたシートを選択
Worksheets(pasteSheetName).Select
Worksheets(pasteSheetName).Cells(1, 1).Select
End Sub
投稿日:

【Excel】各シートの値を集計する

①マクロを使えるようにする
「マクロを使えるようにする」を参照

②集計表のタイトルを用意

③集計するシートを用意

④集計用ボタンを配置

⑤ボタン配置時の以下の画面で「マクロ名」を「Aggregate」として「新規作成」を押す

⑥「Microsoft Visual Basic for Applications」にて以下のコードを記載
※★の部分を作成するレイアウトに合わせて修正

Sub Aggregate()
Dim sheet As Worksheet
'「集計」シートのシート名
Dim aggregateSheetName As String: aggregateSheetName = "集計" '★
'「集計」シートで大学名を表示する列
Dim collegeNameCol As Integer: collegeNameCol = 2 '★
'開始行
Dim startRow As Integer: startRow = 3 '★
'最終行
Dim lastRow As Integer: lastRow = Sheets(aggregateSheetName).Cells(Rows.Count, collegeNameCol).End(xlUp).Row + 1
'各シートで大学名が記載されたCell
Dim collegeNameCell As String: collegeNameCell = "A4" '★

'一旦行をすべてクリア
For i = startRow To lastRow - 1 Step 1
Rows(3).Delete
Next

'全てのシート分繰り返し処理
For Each sheet In Sheets
'「集計」シートの場合は何もしないで次のシートへ
If sheet.Name = aggregateSheetName Then
GoTo CONTINUE
End If

'最終行の再取得
lastRow = Sheets(aggregateSheetName).Cells(Rows.Count, collegeNameCol).End(xlUp).Row + 1

'各シートの大学名が記載されたCellの値を取得
Dim collegeName As String: collegeName = sheet.Range(collegeNameCell).Value

'「集計」シートのB列を３行目から最終行まで走査
For i = startRow To lastRow - 1 Step 1
'一致する行がある場合はC列に１を加算
If Cells(i, collegeNameCol).Value = collegeName Then
Cells(i, collegeNameCol + 1).Value = Cells(i, collegeNameCol + 1).Value + 1
'次のシートへ
GoTo CONTINUE
End If
Next

'最終行まで一致する行がなかった場合
If i = lastRow Then
'最終行のB列に大学名を代入
Cells(i, collegeNameCol).Value = collegeName
'C列に１を加算
Cells(i, collegeNameCol + 1).Value = Cells(i, collegeNameCol + 1).Value + 1
'罫線を引く
Cells(i, collegeNameCol).Borders.LineStyle = xlContinuous
Cells(i, collegeNameCol + 1).Borders.LineStyle = xlContinuous
End If
CONTINUE:
Next
End Sub

⑦「集計」ボタンを押すと各シートの値が集計される