ステータスバーに状況表示
長いマクロから状況表示させる。目立たないけど、無いよりマシ。目立つフォームを使うプログレスバーはネットで検索!
Sub ProgressBarTest()
For x = 1 To 5
'ステータスバーに状況表示
Application.StatusBar = "Progress: " & x & " of 50: " & Format(x / 50, "0%")
Application.Wait Now() + TimeValue("00:00:01")
'ステータスバーから取得も可能。
Debug.Print ("Status取得" & Application.StatusBar)
Next x
'ステータスバーを最後にクリアしておかないといつまでも表示されている。
Application.StatusBar = False
End Sub
一秒待つ
Application.Wait Now() + TimeValue("00:00:01")
0.1秒待つ
Application.Wait [Now() + TimeValue("00:00:00.1")][]で囲むのがポイント。囲っていないと
Application.Wait [Now() + TimeValue("00:00:00.1")]
「型が一致しません」が出る。
Status Animation
何とか目立たせたいと考えて、モデル1。
Sub StatusAnimation()
Dim StatusAnimation() As Variant
StatusAnimation = Array("[==]__", "_[==]_", "__[==]", "__[==]", "_[==]_")
For i = LBound(StatusAnimation) To UBound(StatusAnimation)
Application.StatusBar = StatusAnimation(i)
Application.Wait [Now() + TimeValue("00:00:00.2")]
Next i
Application.StatusBar = False
End Sub
csvファイルから文字列置換を全てのシートで行う
ファイル指定とかしたいが。
Sub 全てのワークシートのからcsvファイルで文字列置換をする()
Dim c As Range
Dim firstAddress As String
'Csvファイル読み込み
'Csvファイルに「検索文字列,置換文字列」で書いておく
'serch string,replace string
'serch string,replace string
'serch string,replace string
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'一気に読み込んで行数を把握
Dim buf As String, tmp As Variant, i As Long
With CreateObject("Scripting.FileSystemObject")
With .GetFile("C:\DELETE\Data.csv").OpenAsTextStream
buf = .ReadAll
.Close
End With
End With
tmp = Split(buf, vbCrLf)
Dim CsvLines() As String
Dim StrFind() As String
Dim StrReplace() As String
ReDim CsvLines(UBound(tmp))
ReDim StrFind(UBound(tmp))
ReDim StrReplace(UBound(tmp))
'解析
For i = 0 To UBound(tmp)
'空行があった。
If (0 < InStr(tmp(i), ",")) Then
Dim CsvSplit As Variant
CsvSplit = Split(tmp(i), ",")
StrFind(i) = CsvSplit(0)
StrReplace(i) = CsvSplit(1)
End If
' Cells(i + 1, 1) = tmp(i)
Next i
For itest = 0 To UBound(tmp)
Next itest
'''''''''''''''''''''''''''''''''''''''''''''''''''
'StrFind と StrReplace 配列に書き込み 完了
'
'これから各ワークシートで処理
'開始
Dim iwork As Integer
For iwork = 1 To Worksheets.Count
'Debug.Print "シート名：" & Worksheets(iwork).Name
'ステータスバーで状況表示
Application.StatusBar = "Progress: " & iwork & " of " & Worksheets.Count & ": " & Format((iwork / Worksheets.Count), "0%") & " シート名：" & Worksheets(iwork).Name
'1ワークシートで処理
'開始
With Worksheets(iwork).UsedRange
For i = LBound(StrFind) To UBound(StrFind)
Set c = .Find(What:=StrFind(i), _
LookIn:=xlValues, LookAt:=xlPart) '---(1)
'条件に当てはまるセルがあるかどうかを判定
If Not c Is Nothing Then
'最初のセルのアドレスを覚える
firstAddress = c.Address
'繰返し検索し、条件を満たすすべてのセルを検索する
Do
c = Replace(c, StrFind(i), StrReplace(i))
Set c = .FindNext(c) '----------------------(2)
If c Is Nothing Then Exit Do
Loop Until c.Address = firstAddress
End If
Next i
'1ワークシートで処理
'終了
End With
'これから各ワークシートで処理
'終了
Next iwork
'ステータスバーのクリア
Application.StatusBar = False
End Subまだまだ
材料の拾い出し
超絶ブサイクマクロだが。今一番使ってる。
言い訳がましいが、あっちこっち手当てしながらのボロボロマクロ。
Public Const 部材長さセル代表 = "E5" '列しか見ないので、5は見ない。直ちに影響はない Rangeに読み込ますため
Public Const 材料長さセル代表 = "L6" '行しか見ないので、Lは見ない。直ちに影響はない
Public Const 材料本数セル代表 = "L7" '行しか見ないので、Lは見ない。直ちに影響はない
Public Const データ開始セル = "I9" 'Functionでは行しか見ないが、Subで列も見るので具体的な開始位置を決める
Sub カッティングプラン検討より拾い出し()
'カッティングプランの検討より
'クリップボードに書き出し
'使い方 カッティングプランで実行 ペースト
'2022-09-02 解消 I8セル等開始したい割り当てのセルを選択。実行
'2022-09-02 解消 一列読み込み式を作ってクリップボードにコピー、セルを右にずらして終了
'2022-09-02 解消 エディタなどに張り付ける。
' 部材長さセル代表 を使って材料データがどこまであるか探る
Dim maxColumn As Long
maxColumn = Cells(Range(材料長さセル代表).Row, Range(データ開始セル).Column).End(xlToRight).Column 'キーの動きによって最後の列を探る最後のセルの絶対位置が帰ってくるので
maxColumn = maxColumn - Range(データ開始セル).Column '[0] から始まる [maxColumn] 個 列がある
'セルをデータ開始位置に用意
Cells(Range(データ開始セル).Row, Range(データ開始セル).Column).Select
'出力するデータホルダ
Dim OutputData As String
For Column1 = 0 To maxColumn
StrSub = 一列の読み込み()
If (Len(StrSub) > 0) Then
StrSubSplit = Split(StrSub, ",")
'あまりに無愛想な結果なのでわかりやすい名前に
CPlan = StrSubSplit(0)
CPTotal = StrSubSplit(1)
CPMaterialLength = StrSubSplit(2)
CPMaterialPCS = StrSubSplit(3)
'細かく出るので二行改行
OutputData = OutputData & CPlan & vbTab & CPTotal & vbTab & CPMaterialLength & vbTab & CPMaterialPCS & vbCrLf & vbCrLf
Debug.Print "OutputData" & OutputData
End If
'一列進める
Cells(ActiveCell.Row, ActiveCell.Column + 1).Select
Next Column1
'' コピペのための組み立て
With CreateObject("Forms.TextBox.1")
.MultiLine = True
.Text = OutputData
.SelStart = 0
.SelLength = .TextLength
.Copy
End With
Debug.Print "一連の動作完了"
End Sub
Function test現在位置()
test現在位置 = "" & ActiveCell.Row & " " & ActiveCell.Column
Debug.Print "現在位置()" & test現在位置
End Function
Function 一列の読み込み()
' 現在セルから一列を読み込み
' 戻り値 切断数式 , 切断長 , 材料長 , 材料本数
' データがなかった場合何も返さないので Len を使って判断する。
'今のところ縦一列しか動作しない
Dim maxrow As Long
Dim i As Long
Dim Sn1 As Worksheet, Sn2 As Worksheet
Dim Key As Long
Dim Obj As Object
Set Sn1 = ActiveSheet
'Set Sn2 = ThisWorkbook.Sheets("Sheet2")
Set ActiveCellNow = ActiveCell
'''''''''''''''''''''''''''''''''''''''''
'データ読み込み開始行にセルを持ってくる。
''''''''''''''''''''''''''''''''''''''''''
'Application.Goto Sn1.Cells(Range(データ開始セル).Row, ActiveCellNow.Column)
Sn1.Cells(Range(データ開始セル).Row, ActiveCellNow.Column).Select
Set ActiveCellNow = ActiveCell '後で使う変数なので、もう一度最新の位置に直しておく。
ActiveLastCell = ActiveCell.Address '今いるセルの値からセルの最後を探す $J$7
ActiveLastCell = Left(ActiveLastCell, InStr(2, ActiveLastCell, "$")) 'ラストの行数を削る$J$
maxrow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row 'キーの動きによって最後の行を探る
'最終データが「データ開始セル」よりも上にあれば、その列にはデータはない。「割り当て」がヒットしてくるのでreturnする
If (Range(データ開始セル).Row > maxrow) Then
Debug.Print "この列にはデータがなかったので戻ります"
Exit Function
End If
ActiveLastCell = ActiveLastCell & maxrow 'データの範囲を決定する。 $J$70
''''''''''''''''''''''''''''''''''''''''
'Dim rng As Range データの入ってるセルを探索
''''''''''''''''''''''''''''''''''''''
Dim DataCellStr As String '個数が入っている セルを スペースで繋いで列挙
Dim DataCellLength As Long 'データの個数
For Each Rng In Range(ActiveCellNow, ActiveLastCell)
If (Rng > 0) Then 'Rngの範囲一列ぐるっと回して 何かがあれば セルにデータがあるのでストア
'Debug.Print rng.Address(False, False) & " " & rng
'Debug.Print Application.WorksheetFunction.RoundUp(Cells(rng.Row, Range(部材長さセル代表).Column).Value, 0)
'VBA 動的配列がくそ
DataCellStr = DataCellStr & Rng.Address & " "
DataCellLength = 1 + DataCellLength
End If
Next Rng
''''''''''''''''''''''''''''''''''''''''
'やっとデータ格納できる
''''''''''''''''''''''''''''''''''''''''
Dim DataCellAddr() As String 'データの入っているセルが 配列で格納される
Dim 部材長さ() As Long 'セルに対応する長さが配列で格納される
Dim 個数() As Long ' 各々の長さに対する 本数が 格納される
ReDim DataCellAddr(DataCellLength)
ReDim 部材長さ(DataCellLength)
ReDim 個数(DataCellLength)
For i = 0 To (DataCellLength - 1) Step 1
'Debug.Print "ActiveLastCell" & ActiveLastCell "-" & Left(DataCellStr, InStr(DataCellStr, " ") - 1) & "-" & Mid(DataCellStr, InStr(DataCellStr, " ") + 1) & "-"
DataCellAddr(i) = Left(DataCellStr, InStr(DataCellStr, " ") - 1)
DataCellStr = Mid(DataCellStr, InStr(DataCellStr, " ") + 1) & "-"
'Debug.Print Range(DataCellAddr(i))
個数(i) = Range(DataCellAddr(i)).Value
'Debug.Print 個数(i)
部材長さ(i) = Cells(Range(DataCellAddr(i)).Row, Range(部材長さセル代表).Column).Value
部材長さ(i) = Application.WorksheetFunction.RoundUp(Cells(Range(DataCellAddr(i)).Row, Range(部材長さセル代表).Column).Value, 0)
'Debug.Print "*" & DataCellAddr(i) & "-" & 部材長さ(i) & "*" & 個数(i) & "-"
Next i
Dim OutStr As String '切断計算式
Dim OutTotalLength As Double '切断全長
Dim OutMaterialPcs As Double '材料数
Dim OutMaterialLength As Double '材料長さ
'''''''''''''''''''''''''''
'出力のために組み立て
''''''''''''''''''''''''''
'''''''''''
'まずは計算式 同じ数字があってもまとめてないのが問題
'''''''''''
For i = 0 To (DataCellLength - 1) Step 1
If (i > 0) Then
OutStr = OutStr & "+"
End If
OutStr = OutStr & 部材長さ(i)
If (個数(i) > 0) Then
OutStr = OutStr & "x" & 個数(i)
End If
OutTotalLength = OutTotalLength + 部材長さ(i) * 個数(i) 'データを拾いながら全長を計算
Next i
' OutStr = OutStr & "=" & OutTotalLength ' 全長をここで OutStr に足してしまうと応用が効かないので
'Cells(ActiveCellNow.Row, Range(部材長さセル代表).Column).Select
'Debug.Print (OutStr & " " & OutTotalLength)
'Cells(ActiveCellNow.Row, ActiveCellNow.Column).Select
OutMaterialPcs = Cells(Range(材料本数セル代表).Row, ActiveCellNow.Column).Value
OutMaterialLength = Cells(Range(材料長さセル代表).Row, ActiveCellNow.Column).Value
戻り値 = OutStr & "," & OutTotalLength & "," & OutMaterialLength & "," & OutMaterialPcs
'Debug.Print "戻り値" & 戻り値
一列の読み込み = 戻り値
End Function
excelが急に落ちたので退避
イミディエイトウィンドウにデバックprint
Debug.Print "処理開始セル" & 処理開始セルSystem.out.println みたいな。
ここが変だよExcel VBA
‘ Rangeの中にRange property がある。Worksheet.Range とか Range.Range とか
' Rangeの中にRange property がある。Worksheet.Range とか Range.Range とか
' https://excel-ubara.com/excelvba1/EXCELVBA356.html
Dim 並べ替えるRange As Range
Set 並べ替えるRange = Range(Selection, Selection.End(xlDown))
MsgBox (並べ替えるRange.Address)
並べ替えるRange.Sort
Excel マクロを アドイン化
マクロの画面を呼び出さなくてもすぐ実行可能
VBAで「Excelアドイン(*.xlam)」で保存
タブ[開発] – グループ[アドイン] – [アドイン]
有効なアドインから先ほど保存したアドインをチェックしてOK
アドインの編集はxlamを直接開いて編集する
コンパイルエラーのダイアログを表示しない
VBA – ツール – オプション – 編集 タブ
自動構文チェック を off
尚、off にしても構文が間違っている所は赤くなるので良く分かる。
本業設計!! 