【VBA】Twitter お題 「280バイトを超えない範囲で区切りのよいところで分割したい」を解いてみた
Twitter のお題、
280バイトを超えない範囲で区切りのよいところで分割したい
を解いてみました。
お題は、こちら
【エクセルお題】
— エクセルの神髄 (@yamaoka_ss) 2020年6月14日
ツイートの下書きをA1セルに入れています。
バイト数はLENB関数で分かりますが、単純に280バイトで区切ってしまうと文章が尻切れになってしまいます。
そこで280バイトを超えない範囲で区切りのよいところで分割したい。
→画像に続く pic.twitter.com/Noiy2yJMT1
処理の概要
- 先頭から、280バイト切り出し（末尾の２バイト文字がバラバラにならないように）
- 後ろから、区切り文字（"。" or LF）を検索
- その位置まで、配列に格納
- 先頭位置を、移動して、280バイト未満になるまで繰り返し
- 280バイト未満の文字列が残っていれば、それも追加
ある程度の汎用性を持たせているので
正直なところ、効率は良くない方法ですw
専用の関数にして、効率よくする方法はいくつかあるけのだけれど、あえてやってません。
Option Explicit Public Sub hoge() Const MAX_BYTES As Long = 280& Dim sResults() As String Dim sSrc As String Dim lElems As Long Dim i As Long sSrc = Sheet1.Range("A1").Value lElems = splitCustom(sSrc, MAX_BYTES, sResults) For i = 0 To lElems - 1 Sheet1.Range("A2").Offset(i).Value = sResults(i) Next i Debug.Print "Done." End Sub Public Function splitCustom(ByVal sSrc As String, _ ByVal lMaxBytes As Long, _ ByRef sResultArray() As String) As Long Dim sTarget As String Dim sElem As String Dim lDelimPos As Long Dim lIndex As Long Dim lOffset As Long lIndex = 0 ReDim sResultArray(lIndex) sTarget = sSrc Do Until LenByte(sTarget) < lMaxBytes sElem = LeftByte(sTarget, lMaxBytes) lDelimPos = getLastTargetPos(sElem) ReDim Preserve sResultArray(lIndex) If lDelimPos > 0 Then sResultArray(lIndex) = Left$(sElem, lDelimPos) lOffset = lDelimPos + 1 Else sResultArray(lIndex) = sElem lOffset = Len(sElem) + 1 End If lIndex = lIndex + 1 sTarget = Mid$(sTarget, lOffset) Loop If Len(sTarget) > 0 Then ReDim Preserve sResultArray(lIndex) sResultArray(lIndex) = sTarget lIndex = lIndex + 1 End If splitCustom = lIndex End Function Private Function getLastTargetPos(ByVal sSrc As String) As Long Dim sDelimiters(1) As String Dim lDelimPos As Long Dim lResult As Long Dim i As Long sDelimiters(0) = "。" sDelimiters(1) = vbLf lResult = -1 For i = 0 To UBound(sDelimiters) lDelimPos = InStrRev(sSrc, sDelimiters(i)) If lDelimPos > 0 Then If lDelimPos > lResult Then lResult = lDelimPos End If End If Next i getLastTargetPos = lResult End Function Private Function LenByte(ByVal sSrc As String) As Long Dim sConverted As String sConverted = StrConv(sSrc, vbFromUnicode) LenByte = LenB(sConverted) End Function Private Function LeftByte(ByVal sSrc As String, ByVal lBytes As Long) As String Dim sConverted As String Dim sResult As String sConverted = StrConv(sSrc, vbFromUnicode) If LenB(sConverted) <= lBytes Then LeftByte = sSrc Exit Function End If sResult = StrConv(LeftB(sConverted, lBytes + 1), vbUnicode) LeftByte = Left(sResult, Len(sResult) - 1) End Function
実行結果
2020/6/15 追記
正規表現を使用した処理も書いてみました。
Public Function splitCusom2(ByVal sSrc As String, _ ByVal lMaxBytes As Long, _ ByRef sResultArray() As String) As Long Dim re As RegExp Dim mc As MatchCollection Dim sTarget As String Dim sElem As String Dim lIndex As Long Dim lOffset As Long Set re = New RegExp With re .Global = True .MultiLine = True '"."は、"。"にはマッチするが、改行にマッチしないので、途中に改行が含まれていてもマッチさせる .Pattern = "^(.|\n)+(。|\n)" End With lIndex = 0 ReDim sResultArray(lIndex) sTarget = sSrc Do Until LenByte(sTarget) < lMaxBytes ReDim Preserve sResultArray(lIndex) sElem = LeftByte(sTarget, lMaxBytes) Set mc = re.Execute(sElem) If mc.Count > 0 Then sResultArray(lIndex) = mc.Item(0) lOffset = Len(sResultArray(lIndex)) + 1 Else sResultArray(lIndex) = sElem lOffset = Len(sElem) + 1 End If lIndex = lIndex + 1 sTarget = Mid$(sTarget, lOffset) Loop If Len(sTarget) > 0 Then ReDim Preserve sResultArray(lIndex) sResultArray(lIndex) = sTarget lIndex = lIndex + 1 End If splitCusom2 = lIndex End Function
【VBA】組み合わせ数を求める
n個の要素から、r個を抜き出す組み合わせ数を求めてみた。
とりあえず、コードだけ。
解説は、時間とその気が出来たら、後日www
n = 99 なら、全ての r の組み合わせを出力できる。
n = 100 なら、47 <= r <=53 の時、オーバーフローする。
コード
Public Function nCr(ByVal n As Long, ByVal r As Long) As Variant Dim dicD As Dictionary Dim dicM As Dictionary '分母 Dim lDenominatorMin As Long Dim lDenominatorMax As Long '分子 Dim lMoleculeMin As Long Dim lMoleculeMax As Long Dim v As Variant Dim vResult As Variant Dim i As Long Debug.Assert n >= r Debug.Assert r > 0 Set dicD = New Dictionary Set dicM = New Dictionary If n - r >= r Then lDenominatorMax = n - r Else lDenominatorMax = r End If lDenominatorMin = 1 lMoleculeMax = n lMoleculeMin = n - lDenominatorMax + 1 '分母 For i = lDenominatorMin To lDenominatorMax Call primeFactorization(i, dicD) Next i '分子 For i = lMoleculeMin To lMoleculeMax Call primeFactorization(i, dicM) Next i '約分処理 '分母要素から、分子要素を消し込む For Each v In dicD.Keys Debug.Assert dicD.Item(v) > 0 Debug.Assert dicM.Exists(v) Debug.Assert dicM.Item(v) >= dicD.Item(v) If dicM.Item(v) > dicD.Item(v) Then dicM.Item(v) = dicM.Item(v) - dicD.Item(v) Else dicM.Remove v End If Next v '組み合わせ数のオーバーフロー対策として、Decimalを使用する vResult = CDec(1) For Each v In dicM.Keys vResult = vResult * (CDec(v) ^ dicM.Item(v)) Next v ' Debug.Print "Result:" & Format(vResult, "#,##0") nCr = vResult End Function '素因数分解 '例： 'lValue（素因数分解する値）に12を指定した場合、 ' 12 = 2 ^2 * 3 ^1 'なので、 'dicPrimeFactorには、 'Key Item ' 2 2 ' 3 1 'が格納されて返る Private Sub primeFactorization(ByVal lValue As Long, ByRef dicPrimeFactor As Dictionary) Dim lPrimeFactor As Long Dim lTargetValue As Long Dim v As Variant If dicPrimeFactor Is Nothing Then Set dicPrimeFactor = New Dictionary End If lTargetValue = lValue '素因数初期値 lPrimeFactor = 2 Do While lTargetValue >= lPrimeFactor * lPrimeFactor If (lTargetValue Mod lPrimeFactor) = 0 Then If dicPrimeFactor.Exists(lPrimeFactor) Then dicPrimeFactor.Item(lPrimeFactor) = dicPrimeFactor.Item(lPrimeFactor) + 1 Else dicPrimeFactor.Add lPrimeFactor, 1 End If lTargetValue = lTargetValue \ lPrimeFactor Else lPrimeFactor = lPrimeFactor + 1 End If Loop '最後に残った物も、素因数なので、追加する 'lPrimeFactor は、2から始めているので、Keyに1は存在しない。 If dicPrimeFactor.Exists(lTargetValue) Then dicPrimeFactor.Item(lTargetValue) = dicPrimeFactor.Item(lTargetValue) + 1 ElseIf lTargetValue <> 1 Then '1は、結果に影響を与えないので、無視する dicPrimeFactor.Add lTargetValue, 1 End If End Sub
実行例
for i=1 to 50:? i & ":" & nCr(99,i):next
1:99
2:4851
3:156849
4:3764376
5:71523144
6:1120529256
7:14887031544
8:171200862756
9:1731030945644
10:15579278510796
11:126050526132804
12:924370524973896
13:6186171974825304
14:38000770702498296
15:215337700647490344
16:1130522928399324306
17:5519611944537877494
18:25144898858450330806
19:107196674080761936594
20:428786696323047746376
21:1613054714739084379224
22:5719012170438571889976
23:19146258135816088501224
24:60629817430084280253876
25:181889452290252840761628
26:517685364210719623706172
27:1399667836569723427057428
28:3599145865465003098147672
29:8811701946483283447189128
30:20560637875127661376774632
31:45764000431735762419272568
32:97248500917438495140954207
33:197443926105102399225573693
34:383273503615787010261407757
35:711793649572175876199757263
36:1265410932572757113244012912
37:2154618614921181030658724688
38:3515430371713505892127392912
39:5498493658321124600506947888
40:8247740487481686900760421832
41:11868699725888281149874753368
42:16390109145274293016493707032
43:21726423750712434928840495368
44:27651812046361280818524266832
45:33796659167774898778196326128
46:39674339023040098565708730672
47:44739148260023940935799206928
48:48467410615025936013782474172
49:50445672272782096667406248628
50:50445672272782096667406248628
【C++】Twitter のお題 「魚の数を数えろ！」を正規表現を使って解いてみた
ゴールデンウィークに行われた、Twitter のお題
「魚の数を数えろ！」
「魚の数を数えろ！ 蟹バージョン」
を今更ながら、C++で正規表現を使って解いてみた。
物足りない人向けに、ちょっと難易度を上げた
— 空腹おやじ (@Z1000R_LR) 2020年5月6日
アレンジ問題を。
タラバガニ毛ガニタラバガニ毛ガニ越前蟹タラバガニ花咲蟹越前蟹越前蟹越前蟹ズワイガニズワイガニ越前蟹タラバガニズワイガニ
１．カニの種類は、何種類か？
２．それぞれのカニはいくつあるか？
を求めてください。
複数のマッチがある場合の繰り返し処理がわからず、あちこち探してやっと完成。
結局、開始位置をイテレーターで、移動させ、マッチしなくなるまでループさせるという方法に落ち着いた。
他にもっと良い方法をご存知の方がいらっしゃいましたら、教えて下さい。
#include <iostream> #include <string> #include <unordered_map> #include <regex> using namespace std; void countFish(); void countCrab(); int main() { wcout.imbue(locale("japanese")); wcout << L"Fish" << endl; countFish(); wcout << L"\nCrab" << endl; countCrab(); return 0; } void countFish() { const wstring sFish{ L"鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵鯖鯵" }; unordered_map<wstring, int> m; for (auto i = 0; i < sFish.length(); ++i) ++m[sFish.substr(i, 1)]; for (const auto& mi : m) wcout << mi.first << L"::" << mi.second << endl; } void countCrab() { const wstring sCrab{ L"タラバガニ毛ガニタラバガニ毛ガニ越前蟹タラバガニ花咲蟹越前蟹越前蟹越前蟹ズワイガニズワイガニ越前蟹タラバガニズワイガニ" }; unordered_map<wstring, int> m; wregex re(L"(?:(^|蟹|ガニ))(.+?)(蟹|ガニ)"); wsmatch mc; auto it = sCrab.cbegin(); while (regex_search(it, sCrab.cend(), mc, re)) { ++m[mc[2].str() + mc[3].str()]; it = mc.suffix().first; } for (const auto& mi : m) wcout << mi.first << L"::" << mi.second << endl; }
実行結果
【VBA】Excelのユーザーフォームをフェードイン、フェードアウトさせてみた
はじめに
Windows では、Windows 2000 Professional 以降のバージョンで、ウインドウに対して、特定の拡張ウインドウスタイルを適用し、レイヤード ウィンドウ化することで、
- アルファブレンドによる、ウィンドウの半透過状態
- カラーキーによる、特定色部の透過
を行うことが出来るようになりました。
今回は、エクセルのユーザーフォームに対し、アルファブレンドを設定し、ユーザーフォームのフェードイン、フェードアウトを行ってみます。
Twitter に載せたやつを、少し修正したものです。
昨日の透過を使って、フォームのフェードイン、フェードアウトをやってみた。
— 空腹おやじ (@Z1000R_LR) 2020年5月12日
Forループで、SetLayeredWindowAttributes の bAlpha を増減しているだけ。 pic.twitter.com/Jz0LULXGIP
使用するAPI
FindWindow
ユーザーフォームのウィンドウハンドルを取得します。
HWND FindWindowA( LPCSTR lpClassName, LPCSTR lpWindowName );
今回は、手っ取り早く
lpClassNameには、vbNullString
lpWindowNameには、ユーザーフォームのCaptionを指定します。
GetWindowLongPtr
指定したウィンドウのスタイルを取得します。
LONG_PTR GetWindowLongPtrA(
HWND hWnd,
int nIndex
);
hWndには、FindWindowで取得した、ユーザーフォームのウインドウハンドルを指定します。
nIndexには、GWL_EXSTYLE を指定することで、ユーザーフォームに設定されている拡張ウィンドウスタイルを取得することができます。
SetWindowLongPtrA
指定したウィンドウに、スタイルを設定します。
LONG_PTR SetWindowLongPtrA(
HWND hWnd,
int nIndex,
LONG_PTR dwNewLong
);
dwNewLong に、「GetWindowLongPtr で取得した拡張ウィンドウスタイルに対し、WS_EX_LAYEREDを追加した値を設定」することで、レイヤードウィンドウとすることができます。
SetLayeredWindowAttributes
今回の主役です。
ウィンドウの不透明度を設定します。
今回は使用しませんが、指定した色を透過させる事もできます。
BOOL SetLayeredWindowAttributes( HWND hwnd, COLORREF crKey, BYTE bAlpha, DWORD dwFlags );
crKeyには、レイヤードウィンドウを合成するときに使われる透明色キーを指定します。
bAlphaには、レイヤード ウィンドウの不透明度を表現するために使用されるアルファ値を指定します。
値は、0 から 255 の範囲で、0を指定すると、ウィンドウは完全に透明になり、255を指定すると、ウィンドウは不透明になります。
dwFlagsには、LWA_ALPHA 、LWA_COLORKEY のいずれかひとつ、または両方を指定できます。
LWA_COLORKEY を指定すると、透過させる色の指定が有効になります。
LWA_ALPHA を指定すると、ウィンドウの不透明度の指定が有効になります。
拡張ウィンドウスタイル
拡張ウィンドウスタイルには、多数のスタイルがあり、今回はその中から、WS_EX_LAYERED を使用します。
docs.microsoft.com
コード
事前準備
予め、frmFade というユーザーフォームを作っておき、
Caption に、FadeForm という文字列を設定しておきます。
標準モジュール
掲載しているのは、64bit版のコードです。
32bit版で使用する場合には、いくつかの修正が必要です。
32bit環境がないので、未確認ですが、最低でも以下の修正が必要と思われます。
- Declare の PtrSafe 削除
- GetWindowLongPtr ==> GetWindowLong
- GetWindowLongPtr のreturn LongPtr ==> Long
- SetWindowLongPtr ==>SetWindowLong
- SetWindowLongPtr の dwNewLong の型 LongPtr ==> Long
- hwnd の型 LongPtr ==> Long
- lExStyle の型 LongPtr ==> Long
Option Explicit Private Const WS_EX_LAYERED = &H80000 Private Const LWA_COLORKEY = &H1& Private Const LWA_ALPHA = &H2& Private Const GWL_EXSTYLE = -20& Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, _ ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" _ (ByVal hwnd As LongPtr, _ ByVal nIndex As Long) As LongPtr Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _ (ByVal hwnd As LongPtr, _ ByVal nIndex As Long, _ ByVal dwNewLong As LongPtr) As LongPtr Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" _ (ByVal hwnd As LongPtr, _ ByVal crKey As Long, _ ByVal bAlpha As Long, _ ByVal dwFlags As Long) As Long Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long) Public Sub showForm() Dim f As frmFade Dim hwnd As LongPtr Dim lExStyle As LongPtr Dim lResult As Long Dim i As Long Set f = frmFade 'いきなり f.Show とすると、表示されてしまうので、Load するだけ Load f 'タイトルを使って、ウィンドウハンドルを取得する hwnd = FindWindow(vbNullString, "FadeForm") lExStyle = GetWindowLongPtr(hwnd, GWL_EXSTYLE) If (lExStyle And WS_EX_LAYERED) = 0 Then 'WS_EX_LAYEREDが未設定なら、拡張スタイルに、WS_EX_LAYERED を付与する lExStyle = lExStyle Or WS_EX_LAYERED Call SetWindowLongPtr(hwnd, GWL_EXSTYLE, lExStyle) End If '初期は､完全透過状態で表示させる Call SetLayeredWindowAttributes(hwnd, 0, 0, LWA_ALPHA) f.Show For i = 5 To 255 Step 5 '不透明度を、上げていく Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA) DoEvents Call Sleep(40) Next i Call Sleep(1000) For i = 255 To 0 Step -5 '不透明度を、下げていく Call SetLayeredWindowAttributes(hwnd, 0, i, LWA_ALPHA) DoEvents Call Sleep(40) Next i Unload f Set f = Nothing End Sub
実行サンプル
何かのネタに使えるようなら使ってみて下さい。
【VBA】Twitter お題「ねこちゃんの数を数える」を解いてみた
Twitter で、ほえほえ氏から提示されたお題「ねこちゃんの数を数える」を解いてみた。
少しお題を考えたので投稿してみます。お題のためのお題ということで少し不自然だし、簡単な解法があるかもしれませんがご容赦を。発展型で言ってみます。
— ほえほえ＠LWP (@hoehoe1234) 2020年2月23日
お題 ねこちゃんの数を数える
です。（つづく）
ざっくり言えば、「親猫」、「子猫」、「猫又」・・・といった文字が並んでいて、
それぞれ何匹いるのかを数えるというもの。
take 1からtake 7まであって、
それぞれに条件がついています。
| Take | 条件 | 文字列 |
|---|---|---|
| 1 | 親猫と子猫を数えて（数と種類を報告）ください。 | 親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫 |
| 2 | 簡潔に書くために同じ種類の猫が連続する場合は「猫」一文字で代用することにしました。 「親猫猫子猫猫」は、親猫が２匹、子猫が２匹です。 |
親猫猫猫子猫猫猫猫猫猫親猫子猫猫 |
| 3 | せっかく簡潔に書く記法を開発したのに適当に書くやつが現れました。そのせいで繰り返しの代わりに元の記法もOKになりました。 親猫が３匹の場合下のいづれもOKとします。 親猫親猫親猫 親猫猫親猫 親猫猫猫 |
子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫 |
| 4 | なんと列に「猫又」が混じってしまいました。親猫、子猫、猫又の数を数えてください。 | 子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫 |
| 5 | いままでは親猫子猫猫又でしたがいろいろな種類の猫がが混じってしまいました。 ただし猫の名前は２文字で最後に「猫」がつくのは同じです。 例で白猫黒猫がいますが実際はもっとたくさんの種類がいます。（青猫、緑猫とか） |
子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫 |
| 6 | なんと不条理な上司！登場。あろうことか、「猫又が二匹現れたらその時点で猫の種類と数を報告して作業を終了せよ」といわれました。どうしよう。。。 上司によると猫又２匹とは「累計して２匹」現れたらとのことで、連続２匹ということではない模様です。 "子猫猫又親猫猫又" "子猫親猫猫又猫" はともに最後の猫又で「累計２匹」なのでそこで報告して作業終了です。 |
子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫 |
| 7 | 最後の試練。上司が逆ギレしています。どうやら先程の指示は上司の意図ではなかったようです。彼によると 「猫又が不吉なのは『きっちり２匹だけ並んだ』ときだけだ！」 とのことです。累計でもないしなんと猫又が３匹並んでもそれはOK（カウント継続）だそうです。数えられるかな、、、、 |
コード
手っ取り早いので、正規表現で・・・
メイン処理
参照設定は、いつものやつ。
Microsoft VBScript Regular Expressions 5.5
メイン処理で使っているパターンは、
親猫を数える場合を例に取ると
(?:親)(猫*?)(?=(?:猫又|[^猫]|$))
猫に続く猫又を分けなければいけないので
肯定先読みを使用している。
"親猫又"
がある場合には、
猫又
を優先している。
親猫を優先したい場合には、
"(猫*?)"を"(猫+?)"に変えればいい（はず）。
(?:親)(猫+?)(?=(?:猫又|[^猫]|$))
親の部分が変わるだけで、
Take 1 から、Take 7 まで全て同じパターンで処理している。
Public Function 猫5改2(ByVal sCats As String, ByRef sCatType() As String, ByRef lCatCount() As Long) As Long Dim re As RegExp Dim mc As MatchCollection Dim lCount As Long Dim lNekomata As Long Dim sResult As String Dim sTypes() As String Dim lElems As Long Dim i As Long Dim j As Long ReDim sCatType(lCount) ReDim lCatCount(lCount) '猫又 lNekomata = (Len(sCats) - Len(Replace$(sCats, "猫又", ""))) \ 2 If lNekomata > 0 Then ReDim Preserve sCatType(lCount) sCatType(lCount) = "猫又" ReDim Preserve lCatCount(lCount) lCatCount(lCount) = lNekomata lCount = lCount + 1 End If 猫5改2 = lCount '猫と又を消して、猫の種類の文字のみにする sResult = Replace$(sCats, "猫", "") sResult = Replace$(sResult, "又", "") ReDim sTypes(0) lElems = -1 '"猫"の前に付く文字を抜き出す（"又"は含まれない） Do Until Len(sResult) = 0 lElems = lElems + 1 ReDim Preserve sTypes(lElems) sTypes(lElems) = Left$(sResult, 1) sResult = Replace$(sResult, sTypes(lElems), "") Loop If lElems < 0 Then Exit Function End If Set re = New RegExp With re .Global = True For i = LBound(sTypes) To UBound(sTypes) .Pattern = "(?:" & sTypes(i) & ")(猫*?)(?=(?:猫又|[^猫]|$))" Set mc = .Execute(sCats) sResult = "" For j = 0 To mc.Count - 1 sResult = sResult & mc.Item(j).SubMatches(0) Next j CONTINUE_LOOP: If sCats Like "*" & sTypes(i) & "猫*" Then '"親子猫"のような場合、"親猫"は無いので出力しない If Not sCats Like "*" & sTypes(i) & "猫又*" Then '"子猫又"のような場合、"子猫"を出力しない ReDim Preserve sCatType(lCount) sCatType(lCount) = sTypes(i) & "猫" ReDim Preserve lCatCount(lCount) lCatCount(lCount) = Len(sResult) - Len(Replace$(sResult, "猫", "")) lCount = lCount + 1 End If End If Next i End With 猫5改2 = lCount End Function
Take 6、Take 7用補助処理
Public Function get猫6Source(ByVal sCats As String) As String Dim re As RegExp Dim mc As MatchCollection Dim sSource As String Dim lResult As Long Dim i As Long Set re = New RegExp With re .Pattern = "^(.*?猫又){2}" .Global = False Set mc = .Execute(sCats) If mc.Count > 0 Then sSource = mc.Item(0) Else sSource = sCats End If End With get猫6Source = sSource End Function Public Function get猫7Source(ByVal sCats As String) As String Dim re As RegExp Dim mc As MatchCollection Dim sSource As String Set re = New RegExp With re .Pattern = "^.*?[^又]猫又猫又(?!猫又)" .Global = True Set mc = .Execute(sCats) If mc.Count > 0 Then sSource = mc.Item(0) Else sSource = sCats End If End With get猫7Source = sSource End Function
テスト
Public Sub 猫てすと() Dim sCatType() As String Dim lCatCount() As Long Dim sCats As String Dim lResult As Long '----- take1 ----- Erase sCatType, lCatCount sCats = "親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫" lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 2 Debug.Assert sCatType(0) = "親猫" Debug.Assert lCatCount(0) = 3 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 8 '----- take2 ----- Erase sCatType, lCatCount sCats = "親猫猫猫子猫猫猫猫猫猫親猫子猫猫" lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 2 Debug.Assert sCatType(0) = "親猫" Debug.Assert lCatCount(0) = 4 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 8 '----- take3 ----- Erase sCatType, lCatCount sCats = "子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫" lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 2 Debug.Assert sCatType(0) = "子猫" Debug.Assert lCatCount(0) = 9 Debug.Assert sCatType(1) = "親猫" Debug.Assert lCatCount(1) = 4 '----- take4 ----- Erase sCatType, lCatCount sCats = "子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫" lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 3 Debug.Assert sCatType(0) = "猫又" Debug.Assert lCatCount(0) = 3 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 4 Debug.Assert sCatType(2) = "親猫" Debug.Assert lCatCount(2) = 4 '----- take5 ----- Erase sCatType, lCatCount sCats = "子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫" lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 5 Debug.Assert sCatType(0) = "猫又" Debug.Assert lCatCount(0) = 3 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 2 Debug.Assert sCatType(2) = "白猫" Debug.Assert lCatCount(2) = 1 Debug.Assert sCatType(3) = "黒猫" Debug.Assert lCatCount(3) = 4 Debug.Assert sCatType(4) = "親猫" Debug.Assert lCatCount(4) = 4 '----- take6-1 ----- Erase sCatType, lCatCount sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫" sCats = get猫6Source(sCats) lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 7 Debug.Assert sCatType(0) = "猫又" Debug.Assert lCatCount(0) = 2 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 2 Debug.Assert sCatType(2) = "白猫" Debug.Assert lCatCount(2) = 1 Debug.Assert sCatType(3) = "黒猫" Debug.Assert lCatCount(3) = 1 Debug.Assert sCatType(4) = "緑猫" Debug.Assert lCatCount(4) = 1 Debug.Assert sCatType(5) = "青猫" Debug.Assert lCatCount(5) = 4 Debug.Assert sCatType(6) = "親猫" Debug.Assert lCatCount(6) = 1 '----- take6-12 ----- Erase sCatType, lCatCount sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫青猫親猫猫猫猫" sCats = get猫6Source(sCats) lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 7 Debug.Assert sCatType(0) = "猫又" Debug.Assert lCatCount(0) = 1 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 2 Debug.Assert sCatType(2) = "白猫" Debug.Assert lCatCount(2) = 1 Debug.Assert sCatType(3) = "黒猫" Debug.Assert lCatCount(3) = 1 Debug.Assert sCatType(4) = "緑猫" Debug.Assert lCatCount(4) = 1 Debug.Assert sCatType(5) = "青猫" Debug.Assert lCatCount(5) = 5 Debug.Assert sCatType(6) = "親猫" Debug.Assert lCatCount(6) = 5 '----- take7-1 ----- Erase sCatType, lCatCount sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫猫猫又青猫親猫猫猫猫又猫" sCats = get猫7Source(sCats) lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 7 Debug.Assert sCatType(0) = "猫又" Debug.Assert lCatCount(0) = 3 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 2 Debug.Assert sCatType(2) = "白猫" Debug.Assert lCatCount(2) = 1 Debug.Assert sCatType(3) = "黒猫" Debug.Assert lCatCount(3) = 1 Debug.Assert sCatType(4) = "緑猫" Debug.Assert lCatCount(4) = 1 Debug.Assert sCatType(5) = "青猫" Debug.Assert lCatCount(5) = 5 Debug.Assert sCatType(6) = "親猫" Debug.Assert lCatCount(6) = 4 '----- take7-2 ----- Erase sCatType, lCatCount sCats = "子猫猫白猫黒猫緑猫青猫猫猫猫親猫猫又猫又青猫親猫猫猫猫又猫" sCats = get猫7Source(sCats) lResult = 猫5改2(sCats, sCatType, lCatCount) Debug.Assert lResult = 7 Debug.Assert sCatType(0) = "猫又" Debug.Assert lCatCount(0) = 2 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 2 Debug.Assert sCatType(2) = "白猫" Debug.Assert lCatCount(2) = 1 Debug.Assert sCatType(3) = "黒猫" Debug.Assert lCatCount(3) = 1 Debug.Assert sCatType(4) = "緑猫" Debug.Assert lCatCount(4) = 1 Debug.Assert sCatType(5) = "青猫" Debug.Assert lCatCount(5) = 4 Debug.Assert sCatType(6) = "親猫" Debug.Assert lCatCount(6) = 1 Debug.Print "Done." End Sub
Debug.Assert で済ませたので、イミディエイトウィンドウに
Done.
と出て、終わり。
ちなみに、イミディエイトウィンドウに出力すると、こんな感じ。
以上。
「改2」は、バージョンです。ツッコまないでくださいwww
正規表現を使わないバージョン（2020/3/1追加）
- Take 1～5 限定です。
- 正規表現バージョンより、精度が低いです。
- お題で提示されているデータは、クリアしますが、元になる猫データが変わると、要件をクリアできない場合があります。
- 正規表現バージョンとは、出力順が違います。
コード
Public Function 猫猫(ByVal sCats As String, ByRef sCatType() As String, ByRef lCatCount() As Long) As Long Dim dicCount As Dictionary Dim lLength As Long Dim lStartPos As Long Dim lOffset As Long Dim sCurrentType As String Dim sType As String Dim lCount As Long lLength = Len(sCats) If lLength < 2 Then Exit Function End If Set dicCount = New Dictionary 'グループ開始位置 lStartPos = 1 lOffset = 0 '現在の猫の種類 sCurrentType = "" sType = Mid$(sCats, lStartPos, 1) Do While True Select Case sType Case "猫" If Mid$(sCats, lStartPos + lOffset + 1, 1) <> "又" Then '猫又ではない lCount = lCount + 1 lOffset = lOffset + 1 Else '猫又 lStartPos = lStartPos + lOffset + 2 lOffset = 0 If dicCount.Exists("又") = True Then dicCount.Item("又") = dicCount.Item("又") + 1 Else dicCount.Add "又", 1 End If If Len(sCurrentType) > 0 Then If dicCount.Exists(sCurrentType) = True Then dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount End If End If sCurrentType = "" End If Case Else If sCurrentType <> sType Then '猫の種類が変わった lStartPos = lStartPos + lOffset + 1 lOffset = 0 If dicCount.Exists(sCurrentType) = True Then 'カウントアップ dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount End If If Len(sType) > 0 Then If dicCount.Exists(sType) = False Then '新しい猫の種類を追加 dicCount.Add sType, 0 End If End If '現在の猫の種類を更新 sCurrentType = sType 'カウントクリア lCount = 0 Else lOffset = lOffset + 1 End If End Select sType = Mid$(sCats, lStartPos + lOffset, 1) '終了判定（lStartPos + lOffset > lLength で、sType = ""となる） If Len(sType) = 0 Then If Len(sCurrentType) > 0 Then '有効データならカウントアップ dicCount.Item(sCurrentType) = dicCount.Item(sCurrentType) + lCount End If Exit Do End If Loop '-------------------------------------------------- Dim v As Variant Dim lElems As Long ReDim sCatType(dicCount.Count - 1) ReDim lCatCount(dicCount.Count - 1) For Each v In dicCount If Len(v) > 0 Then If dicCount.Item(v) > 0 Then If v <> "又" Then sCatType(lElems) = v & "猫" Else sCatType(lElems) = "猫" & v End If lCatCount(lElems) = dicCount.Item(v) lElems = lElems + 1 End If End If Next v If dicCount.Count <> lElems Then '未登録データが有れば、排除 ReDim Preserve sCatType(lElems - 1) ReDim Preserve lCatCount(lElems - 1) End If 猫猫 = lElems End Function
テスト
Public Sub 猫猫テスト() Dim sCatType() As String Dim lCatCount() As Long Dim sCats As String Dim lResult As Long '----- take1 ----- Erase sCatType, lCatCount sCats = "親猫子猫子猫子猫子猫子猫子猫親猫親猫子猫子猫" lResult = 猫猫(sCats, sCatType, lCatCount) Debug.Assert lResult = 2 Debug.Assert sCatType(0) = "親猫" Debug.Assert lCatCount(0) = 3 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 8 '----- take2 ----- Erase sCatType, lCatCount sCats = "親猫猫猫子猫猫猫猫猫猫親猫子猫猫" lResult = 猫猫(sCats, sCatType, lCatCount) Debug.Assert lResult = 2 Debug.Assert sCatType(0) = "親猫" Debug.Assert lCatCount(0) = 4 Debug.Assert sCatType(1) = "子猫" Debug.Assert lCatCount(1) = 8 '----- take3 ----- Erase sCatType, lCatCount sCats = "子猫猫子猫猫親猫猫子猫親猫子猫親猫子猫猫子猫" lResult = 猫猫(sCats, sCatType, lCatCount) Debug.Assert lResult = 2 Debug.Assert sCatType(0) = "子猫" Debug.Assert lCatCount(0) = 9 Debug.Assert sCatType(1) = "親猫" Debug.Assert lCatCount(1) = 4 '----- take4 ----- Erase sCatType, lCatCount sCats = "子猫猫子猫猫親猫猫又猫猫猫又親猫猫猫猫又猫" lResult = 猫猫(sCats, sCatType, lCatCount) Debug.Assert lResult = 3 Debug.Assert sCatType(0) = "子猫" Debug.Assert lCatCount(0) = 4 Debug.Assert sCatType(1) = "親猫" Debug.Assert lCatCount(1) = 4 Debug.Assert sCatType(2) = "猫又" Debug.Assert lCatCount(2) = 3 '----- take5 ----- Erase sCatType, lCatCount sCats = "子猫猫白猫黒猫猫猫猫親猫猫又猫猫猫又親猫猫猫猫又猫" lResult = 猫猫(sCats, sCatType, lCatCount) Debug.Assert lResult = 5 Debug.Assert sCatType(0) = "子猫" Debug.Assert lCatCount(0) = 2 Debug.Assert sCatType(1) = "白猫" Debug.Assert lCatCount(1) = 1 Debug.Assert sCatType(2) = "黒猫" Debug.Assert lCatCount(2) = 4 Debug.Assert sCatType(3) = "親猫" Debug.Assert lCatCount(3) = 4 Debug.Assert sCatType(4) = "猫又" Debug.Assert lCatCount(4) = 3 Debug.Print "Done." End Sub
【VBA】導関数を求める
Twitter でのお題
「y = 5x^3 + 2x^2 + 7x + 5」の導関数を求めろ！
を解いてみた。
正規表現を使って、必要なデータを取り出して、ゴニョゴニョしました。
使用したパターンは、以下の通り。
"([+-]?)(\d*)x(\^([+-]?\d+))?"
大雑把な説明
x に対して、
| [+-]? | 符号 + または、- が付く場合がある |
| \d* | 任意の正の整数の係数が付く場合がある |
| (\^([+-]?\d+))? | 冪乗指数が付く場合がある |
| [+-]? | 冪乗指数には、符号 + または、- が付く場合がある |
| \d+ | 冪乗指数は、正の整数である |
係数、指数を
正の整数
としているのは、
符号部と数値部を別に判定しているためです。
参照設定は、お約束の通り。
Private Type xItem xiSign As String xiCoefficient As Long xiPower As Long End Type Public Sub hoge() Dim sFormula As String sFormula = "y = 5x^3 + 2x^2 + 7x + 5" Debug.Print sFormula Debug.Print getDerivative改(sFormula) Debug.Assert getDerivative改(sFormula) = "y=15x^2+4x+7" sFormula = "y = 7x - 5x^3 + 2x^2" Debug.Print sFormula Debug.Print getDerivative改(sFormula) Debug.Assert getDerivative改(sFormula) = "y=7-15x^2+4x" sFormula = "y = 7x^+9-3x^5+12x^-3-x^2+10x+4" Debug.Print sFormula Debug.Print getDerivative改(sFormula) Debug.Assert getDerivative改(sFormula) = "y=63x^8-15x^4-36x^-4-2x+10" sFormula = "y = 7x^9-3x^5-22x^-3+4x^2+x+4" Debug.Print sFormula Debug.Print getDerivative改(sFormula) Debug.Assert getDerivative改(sFormula) = "y=63x^8-15x^4+66x^-4+8x+1" sFormula = "y = 5" Debug.Print sFormula Debug.Print getDerivative改(sFormula) Debug.Assert getDerivative改(sFormula) = "" End Sub Private Function getDerivative改(ByVal sFormula As String) As String Dim xi() As xItem Dim sFormulaW As String Dim sItem As String Dim sSign As String Dim sResult As String Dim i As Long sFormulaW = Replace$(sFormula, " ", "") If Not getItemInfo改(sFormulaW, xi) Then Debug.Print "Not matched." Exit Function End If For i = 0 To UBound(xi) With xi(i) If (.xiSign = "-") Eqv (Sgn(.xiPower) < 0) Then sSign = "+" Else sSign = "-" End If sItem = sSign & CStr(.xiCoefficient * Abs(.xiPower)) & "x" '指数部の値による処理の振り分け Select Case .xiPower Case 0 '何も付加しない Case 1 '符号、係数部のみ使用し、"x"および指数部は付加しない sResult = sResult & .xiSign & CStr(.xiCoefficient) Case 2 '指数部は１なので、"^"以降は省略する sResult = sResult & sItem Case Else '指数部が２より大きい or ０未満 sResult = sResult & sItem & "^" & CStr(.xiPower - 1) End Select End With Next i If Left$(sResult, 1) = "+" Then sResult = Mid$(sResult, 2) End If getDerivative改 = "y=" & sResult End Function Private Function getItemInfo改(ByVal sFormula As String, ByRef xi() As xItem) As Boolean Dim re As New RegExp Dim mc As MatchCollection Dim i As Long With re .Global = True .MultiLine = False .IgnoreCase = True .Pattern = "([+-]?)(\d*)x(\^([+-]?\d+))?" End With Set mc = re.Execute(sFormula) If mc.Count = 0 Then Exit Function End If ReDim xi(mc.Count - 1) For i = 0 To mc.Count - 1 With xi(i) .xiSign = mc.Item(i).SubMatches(0) If mc.Item(i).SubMatches(1) = "" Then .xiCoefficient = 1 Else .xiCoefficient = CLng(mc.Item(i).SubMatches(1)) End If If mc.Item(i).SubMatches(3) = "" Then .xiPower = 1 Else .xiPower = CLng(mc.Item(i).SubMatches(3)) End If End With Next i getItemInfo改 = True End Function
実行結果
y = 5x^3 + 2x^2 + 7x + 5
y=15x^2+4x+7
y = 7x - 5x^3 + 2x^2
y=7-15x^2+4x
y = 7x^+9-3x^5+12x^-3-x^2+10x+4
y=63x^8-15x^4-36x^-4-2x+10
y = 7x^9-3x^5-22x^-3+4x^2+x+4
y=63x^8-15x^4+66x^-4+8x+1
y = 5
Not matched.Not matched.
ちなみに、同じく正規表現を使用た方法は、こちらにも。
infoment.hatenablog.com
ExcelのVBAで使えるDLLを、C++（Visual Studio 2017）で作る。・・・その６ デバッグ編
初めに
DLLを作ってきましたが、作ったからには、動作確認が必要です。
今回は、DLLのデバッグ方法についてです。
このシリーズの記事を読んでくださった方は、基本的にVBAのデバッグ経験者と思います。
ブレークポイントを設定して、ステップ実行したり・・・
基本的な部分は、DLLのデバッグでも同様です。
私の場合、VBAのコードから、DLLのコードにどうやって入っていくのかが
最初の時、わからなかったのでそのあたりについて説明します。
（VBAでのデバッグ経験があることを前提に、類似した細かい部分は、端折ります。）
キーワード
アタッチ
アタッチとは、
デバッガーがプロセスやタスクを監視対象にすること
https://www.wdic.org/w/TECH/%E3%82%A2%E3%82%BF%E3%83%83%E3%83%81
今回の場合、Excelに接続して、監視できるようにするといった感じでしょうか。
デタッチ
こちらは、アタッチの逆。
アタッチした対象を監視下から外して、切り離すことです。
実際にやってみる
操作の流れ
- DLLを呼び出すExcelファイルの起動
- Visual Studio（DLLソリューション）の起動
- アタッチ
- DLL側コードへのブレークポイント設定
- VBAからDLL関数の呼び出し
- DLLコードのステップ実行
- デタッチ
アタッチ
- 対象のExcelファイルと、DLLソリューションを開く。
- Visual Studioのソリューション構成が「Debug」になっているか、確認しておくこと。
- DLLのプロジェクトがビルド済みであること。
- Visual Studioのソリューション構成が「Debug」になっているか、確認しておくこと。
- Visual Studioのメニューから、プロセスにアタッチを選択。
- 「デバッグ」-「プロセスにアタッチ」をクリック
- 「デバッグ」-「プロセスにアタッチ」をクリック
- プロセスにアタッチダイアログから、DLLの呼び出し元となるExcelを探して、選択し、アタッチボタンをクリック。
ブレークポイント
デバッグを開始する部分に、ブレークポイントを設定する。
F9キーで、ブレークポイントの設定、解除ができます。
ブレークポイントを設定したら、VBA側からDLLの関数を呼び出すコードを実行します。
ステップオーバー
１コードステートメントを実行します。
ステップインと違うのは、対象行が、関数の呼び出しの場合、
呼び出し先の関数を実行しますが、呼び出し先関数の内部コードをステップ実行しません。
ショートカットキーは、F10キーです。
ステップアウト
ステップインとは逆に、ステップインした関数から抜ける場合に使用します。
ショートカットキーは、Shift + F11キーです。
デバッグの停止
全てデタッチ
プロセスに再アタッチ
一度アタッチしたプロセスをデタッチした後に、再度同じプロセスにアタッチしたい場合には、プロセスに再アタッチを選択すると、アタッチするプロセスを選択する手間が省けます。
ショートカットキーは、Shift + Alt + P です。
ウォッチ
変数を右クリックして、ウォッチの追加をクリック
確認してみる。
自動変数
ウォッチのように自分で追加しなくても、スコープに応じて表示される変数が変わっていく。
ローカル
ウォッチのように自分で追加しなくても、スコープに応じて表示される変数が変わっていく。
主なショートカットキー
VBA と Visual Studio では、微妙にショートカットキーが違うので・・・
VBE でF8キーを押して、Visula Studio に入っても、F8キーを押して、
「あれ、進まない？あっ、F10だった。」とかよくやってますwww
| 項目 | VBA | Visual Studio | 備考 |
|---|---|---|---|
| ブレークポイントの設定/解除 | F9 | F9 | |
| 全てのブレークポイントの解除 | Ctrrl + Shift + F9 | Ctrrl + Shift + F9 | |
| ステップイン | F8 | F11 | |
| ステップオーバー | Shift + F8 | F10 | |
| ステップアウト | Ctrl + Shift + F8 | Shift + F11 | |
| カーソル行の前まで実行 | Ctrl + F8 | Ctrl + F10 | |
| デバッグの停止 | Shift + F5 |
その他（情報提供依頼）
Rubberduckというアドインがあって、便利そうだのだけど、
こいつをインストールしたところ、Visual Studioでアタッチしても、ExcelのVBEから入っていけない（デバッグできない）現象に遭遇。
現状アンイストールしか対応方法がわからずじまい。
解決策をご存知の方、いらっしゃいましたら教えてください。
最後に
今回で、VBAで使えるDLL作成に関する記事は終了です。
後半は、手抜き気味のような気もしますが、参考になれば幸いです。
