テックメモ – 自分用のメモです。内容が間違っていたり、作りかけで動作しないコードなどあるのでご注意ください。

2023-12-062023-12-06

VBA 指定した区間の差を取得

1-10,11-20,21-末で区間を区切って､区間の差を取得する｡

Function GetPeriod(sd, ed)

' 日付かどうか

If IsDate(sd) = False Or IsDate(ed) = False Then
  GetPeriod = "9999"
  Exit Function
End If

' 日付の差が妥当か

If CDate(sd) > CDate(ed) Then
  GetPeriod = "9998"
  Exit Function
End If

sn = DateToNumber(sd)
en = DateToNumber(ed) + 1

If Year(sd) = Year(ed) Then

 ' 年度の差がない場合
 
ElseIf Year(sd) + 1 = Year(ed) Then

  en = en + 36 ' 年度の差が1年の場合+36
  
Else ' 年度の差が2年以上はエラー

  GetPeriod = "9997"
  Exit Function
  
End If

GetPeriod = en - sn

End Function

Function DateToNumber(target)

result = Month(target) * 3 - 2

Select Case Day(target)

  Case 1 To 10
    result = result + 0
  Case 11 To 20
    result = result + 1
  Case Else ' 21～
    result = result + 2
  
End Select

DateToNumber = result

End Function

Sub TestGetPeriod()

' 1-10 11-20 21-30

Debug.Print GetPeriod("a", "2023/12/4"), "9999"
Debug.Print GetPeriod("2023/12/5", "2023/12/4"), "9998"
Debug.Print GetPeriod("2023/12/5", "2023/12/5"), "1"

' 1の区間から2の区間
Debug.Print GetPeriod("2023/12/5", "2023/12/11"), "2"
Debug.Print GetPeriod("2023/12/5", "2023/12/19"), "2"
Debug.Print GetPeriod("2023/12/5", "2023/12/20"), "2"
Debug.Print GetPeriod("2023/12/5", "2023/12/21"), "3"

' 2の区間から3の区間
Debug.Print GetPeriod("2023/1/19", "2023/1/21"), "2"
Debug.Print GetPeriod("2023/1/20", "2023/1/22"), "2"

' 3の区間から
Debug.Print GetPeriod("2023/1/21", "2023/1/22"), "1"
Debug.Print GetPeriod("2023/1/31", "2023/2/1"), "2"

' 年度またぎ
Debug.Print GetPeriod("2023/9/25", "2024/1/10"), "11"
Debug.Print GetPeriod("2023/10/1", " 2024/3/31"), "18"

End Sub

Function GetPeriod(sd, ed)

' 日付かどうか

If IsDate(sd) = False Or IsDate(ed) = False Then

GetPeriod = "9999"

Exit Function

End If

' 日付の差が妥当か

If CDate(sd) > CDate(ed) Then

GetPeriod = "9998"

Exit Function

End If

sn = DateToNumber(sd)

en = DateToNumber(ed) + 1

If Year(sd) = Year(ed) Then

' 年度の差がない場合

ElseIf Year(sd) + 1 = Year(ed) Then

en = en + 36 ' 年度の差が1年の場合+36

Else ' 年度の差が2年以上はエラー

GetPeriod = "9997"

Exit Function

End If

GetPeriod = en - sn

End Function

Function DateToNumber(target)

result = Month(target) * 3 - 2

Select Case Day(target)

Case 1 To 10

result = result + 0

Case 11 To 20

result = result + 1

Case Else ' 21～

result = result + 2

End Select

DateToNumber = result

End Function

Sub TestGetPeriod()

' 1-10 11-20 21-30

Debug.Print GetPeriod("a", "2023/12/4"), "9999"

Debug.Print GetPeriod("2023/12/5", "2023/12/4"), "9998"

Debug.Print GetPeriod("2023/12/5", "2023/12/5"), "1"

' 1の区間から2の区間

Debug.Print GetPeriod("2023/12/5", "2023/12/11"), "2"

Debug.Print GetPeriod("2023/12/5", "2023/12/19"), "2"

Debug.Print GetPeriod("2023/12/5", "2023/12/20"), "2"

Debug.Print GetPeriod("2023/12/5", "2023/12/21"), "3"

' 2の区間から3の区間

Debug.Print GetPeriod("2023/1/19", "2023/1/21"), "2"

Debug.Print GetPeriod("2023/1/20", "2023/1/22"), "2"

' 3の区間から

Debug.Print GetPeriod("2023/1/21", "2023/1/22"), "1"

Debug.Print GetPeriod("2023/1/31", "2023/2/1"), "2"

' 年度またぎ

Debug.Print GetPeriod("2023/9/25", "2024/1/10"), "11"

Debug.Print GetPeriod("2023/10/1", " 2024/3/31"), "18"

End Sub

2023-11-092023-11-09

VBA 選択範囲拡張ショートカット

特定のセルを選択した状態で実行すると、指定した列幅まで選択範囲を拡張する。事務処理で頻繁に目視チェック→塗りつぶしの作業があったため。

Sub test()

ActiveSheet.Range("A" & Split(Selection(1).Address, "$")(2) & ":AA" & Split(Selection(Selection.Count).Address, "$")(2)).Select

End Sub

Sub test()

ActiveSheet.Range("A" & Split(Selection(1).Address, "$")(2) & ":AA" & Split(Selection(Selection.Count).Address, "$")(2)).Select

End Sub

開発＞マクロ＞オプション＞test＞Ctrl+E
(重複しないショートカットを設定)

2023-11-082023-11-08

VBA 選択した複数シートからコピー

複数のシートを選択している状態なので、リボン(メニューバー)にボタンを追加

Sub test()

Application.CommandBars("worksheet menu bar").Reset

End Sub

Sub auto_open()

On Error Resume Next

caption = "選択一覧"

For x = 1 To 3
 Application.CommandBars("worksheet menu bar").Controls(caption).Delete
Next

With Application.CommandBars("worksheet menu bar").Controls.Add(Type:=msoControlButton)
.Style = msoButtonCaption
.caption = caption
.OnAction = "main"
End With

End Sub

Sub auto_close()

caption = "選択一覧"

On Error Resume Next

For x = 1 To 3
 Application.CommandBars("worksheet menu bar").Controls(caption).Delete
Next

End Sub

Sub Initialize()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
    
End Sub

Sub Finalize()

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
    
End Sub

Sub main()

Initialize

caption = "選択一覧"

exists = False
For Each w In Sheets
  If w.Name = caption Then
    exists = True
    Exit For
  End If
Next w

If exists = False Then
  MsgBox caption & "シートが存在しません。"
  Exit Sub
End If

Sheets(caption).Rows("1:1000").Delete

r = 1
For Each w In ActiveWindow.SelectedSheets
  If w.Name <> caption Then
  
    w.Range("A2:AD22").Copy
    Sheets(caption).Cells(r, 1).PasteSpecial xlPasteValues
    w.Range("A2:AD22").Copy
    Sheets(caption).Cells(r, 1).PasteSpecial xlPasteFormats
    
  End If
r = r + 23
Next w

Sheets(caption).Select
Application.CutCopyMode = False

Finalize

End Sub

Sub test()

Application.CommandBars("worksheet menu bar").Reset

End Sub

Sub auto_open()

On Error Resume Next

caption = "選択一覧"

For x = 1 To 3

Application.CommandBars("worksheet menu bar").Controls(caption).Delete

With Application.CommandBars("worksheet menu bar").Controls.Add(Type:=msoControlButton)

.Style = msoButtonCaption

.caption = caption

.OnAction = "main"

End With

End Sub

Sub auto_close()

caption = "選択一覧"

On Error Resume Next

For x = 1 To 3

Application.CommandBars("worksheet menu bar").Controls(caption).Delete

End Sub

Sub Initialize()

Application.ScreenUpdating = False

Application.EnableEvents = False

Application.DisplayAlerts = False

End Sub

Sub Finalize()

Application.DisplayAlerts = True

Application.EnableEvents = True

Application.ScreenUpdating = True

End Sub

Sub main()

Initialize

caption = "選択一覧"

exists = False

For Each w In Sheets

If w.Name = caption Then

exists = True

Exit For

End If

Next w

If exists = False Then

MsgBox caption & "シートが存在しません。"

Exit Sub

End If

Sheets(caption).Rows("1:1000").Delete

r = 1

For Each w In ActiveWindow.SelectedSheets

If w.Name <> caption Then

w.Range("A2:AD22").Copy

Sheets(caption).Cells(r, 1).PasteSpecial xlPasteValues

w.Range("A2:AD22").Copy

Sheets(caption).Cells(r, 1).PasteSpecial xlPasteFormats

End If

r = r + 23

Next w

Sheets(caption).Select

Application.CutCopyMode = False

Finalize

End Sub

2023-11-052023-11-11

文章メモ

●素材を集める

素材の種類は「事象」と「意見」がある。事象はネタ、意見は切り口となる。

最低限必要な素材は
・読後感・結論・伝えたいこと(意見)
・理由(意見)
・背景(事象)
文章の種類によって違いがあり、新聞のような文章は事象が多く意見は少ない。コラムやエッセイは逆。書く文章によってどのような素材が必要か考えておく。

素材の中に一つ、続きが読みたいと思うようなフックを準備する。
＞〇〇が流行っているけど、もう使わないほうがいい
＞〇〇社は〇〇を重視へ

●素材を書き出す

素材をもとに頭の中にある言いたいことを、主部と述部の短い文章で書く。ここでは、しっかりとした文章にする必要はない。

●仮見出しを作る

ここで作るのは、
・文章の仮見出し(タイトル)
・章/節の仮見出し
・段落の仮見出し

その仮見出しを実際に使うかどうかは関係ない。先ず仮見出しを作り、仮見出しを並べて文章の骨子を作る。何を伝えたいのか、どの順番で伝えたいのか、など、仮見出しを作ることで明確にできる。

●段落

仮見出しを見ながら、素材として作った文章を振り分ける。

段落の先頭に伝えたいことを持ってくる。関連性が強く分けることが難しい内容は連続して２つ結論を書いてしまう。

結論を補助する文章を以下のような関連性で繋げる。(サポートセンテンス)

順接：　だから、そのため
結果：　その結果
理由：　なぜなら
逆説：　でも、だが、しかし
換言：　つまり
例　：　たとえば
添加：　そのうえ、さらに
補足：　ただし、ちなみに
並列：　また、ならびに
転換：　ところで
対比：　一方
選択：　あるいは
条件：　それなら、そうしましたら

●気をつけること

・過剰に主語を略さない。誰が？なにについて？具体的になにしてくれるの？など、相手の想像力に頼らない。省略が丁寧に感じることが多いので省略しがち。
・換喩、提喩に注意。助詞で区切って、それぞれパーツの中で、自分だけが理解できる表現になっていないか。それは自明なことなのか考える。

・文章はできるだけ短いほうがいいわけではない。意味が正しく伝わるような文章にすることが大切。主部が同じなら「、」で繋げた方が自然な場合が多い。
・紋切り型の表現を避ける。
・書き出しだけは、へぇー、え？、なるほど、となるように。
・句読点や、センテンスの長さはリズムがあるかどうか、歌のように。
・意見、気持ち、事実は普通体にしてみる(する、したがつかない)
・体言止めを活用する場合、ある程度のかたまりごとに文末をつける。
・文末を短くする(させていただきます、という、すること、ついては)
・形容詞は対象に近づける。なるべく具体化して余り使わない。
・抽象表現(高品質など)は明確に。
・ビジネス枕、接続詞はなるべく使わない。
・あの、その、はなるべく使わない。
・が、の、は本当に必要か見直す。
・意味の重複に気をつける。
・受け身(作られている)をやめる。
・考え方を押し付けない。
・誰の意見なのかぼかさない。
・読者が知りたいことは何か？と考える。

2023-10-302023-10-31

VBA Access SQL一括処理

Excelのシート上に保存してあるデータを関数などでSQL化し、一括でAccessに流し込む必要があったので。

Sub test()

With ActiveSheet

Set cn = CreateObject("adodb.connection")
cn.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\x.mdb"

For r = 1 To 138
  q = ActiveSheet.Cells(r, 1).Value
  cn.Execute q
Next r

cn.Close
Set cn = Nothing

MsgBox "done"

End With

End Sub

Sub test()

With ActiveSheet

Set cn = CreateObject("adodb.connection")

cn.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\x.mdb"

For r = 1 To 138

q = ActiveSheet.Cells(r, 1).Value

cn.Execute q

Next r

cn.Close

Set cn = Nothing

MsgBox "done"

End With

End Sub

2023-10-092023-10-10

SoftBank(iPhone) 機種変更

13ProMax→15Pro+XS→13ProMaxへ機種変。

処理の途中でAppleIDの2ファクタ認証のコードが届くので、
旧端末は起動しSIMカードもそのまま。

OSのバージョンが古いと問題が発生することもあるので、とりあえず新旧ともに最新にする。新端末は起動後、クイックスタート等せずセットアップしOSをアップデートしておく。

・Suica/PASMO

旧端末＞ウォレット＞ミートボールメニュー＞カードの詳細＞カードを削除

・PC

Cドライブの容量が少ない場合、シンボリックでバックアップ場所を移動。

C:\Users\mail\AppData\Roaming\Apple Computer\MobileSync
のBackupを削除し、
cmd＞mklink /d “C:\Users\mail\AppData\Roaming\Apple Computer\MobileSync\Backup” “I:\Backup”
を実行。

・iTunesの設定

※データ移行するためにAppleIDでログインする必要はない。

iTunesの同期を停止しておく(バックアップは同期とは別)
編集＞環境設定＞デバイス＞iPod、iPhone、およびiPadを自動的に同期しない
にチェック。

・iTunesでバックアップの実行

※バックアップ用パスワードを覚えてなければ変更しておく

旧端末をiTunesに接続する。

携帯マーク＞概要＞バックアップ＞このコンピュータ(暗号化)＞ローカルバックアップ
にチェックしてあるか確認し、今すぐバックアップを実行する。

バックアップが完了したらケーブルを外す。

・復元

新端末をiTunesに接続する。新しいiPhoneへようこそと表示されるので、このバックアップから復元を実行する。もし復元のダイアログがでてこない場合は、
携帯マーク＞概要＞バックアップ＞バックアップを復元
を実行する。

一通りアプリを起動し、データが引き継がれているか確認する。
ログインが切れたり、VLCなどはファイルが移行されない。

電源を切りSIMカードを移動する。もし機種変で届いた端末にSIMカードが付属していたら、指定のサイトから切替の手続きを実施する。

2023-09-23

Chrome拡張特定の文字が含まれるタブを自動で閉じる

script.jp

chrome.tabs.onUpdated.addListener((tabId, changeInfo, tab) => {
  if (changeInfo.status === 'complete') {
    if (tab.title.includes("アラート!")) {
        chrome.tabs.remove(tabId);
    }
  }
});

chrome.tabs.onUpdated.addListener((tabId, changeInfo, tab) => {

if (changeInfo.status === 'complete') {

if (tab.title.includes("アラート!")) {

chrome.tabs.remove(tabId);

}

});

manifest.json

{
  "manifest_version": 3,
  "name": "AutoCloseTab",
  "version": "1.0",
  "permissions": ["tabs"],
  "background": {
    "service_worker": "script.js"
  }
}

{

"manifest_version": 3,

"name": "AutoCloseTab",

"version": "1.0",

"permissions": ["tabs"],

"background": {

"service_worker": "script.js"

}

2023-09-212023-09-21

Microsoft365 Apps for business 契約

https://www.microsoft.com/ja-jp/microsoft-365/business/compare-all-microsoft-365-business-products
から、今すぐ購入をクリック。

・サブスクリプションを設定する
ユーザー数は1人、請求頻度は期間は1ヶ月とした。

・メールアドレスの入力
現在使っているメインのアドレスはMicrosoftの個人アカウントなので、新しく作成したアドレスを入力し、アカウントのセットアップをクリック。

・氏名など入力、会社名は適当に個人事業主、会社の規模は1人。

・電話番号の認証。

・サインインする方法
ユーザー名、ドメイン名(Microsoft指定のドメインに対して、サブドメインを指定する)、パスワードを決定する。

※どうやらこの画面では、既に所有しているドメイン名を使うを選択できないらしい。

・お支払い方法の追加、PayPalは指定できずクレジットカードのみ、必要な情報を入力。

・最後に契約に同意して発注をクリック。

＊＊＊

最初に入力した、新しく作成したアドレスは
Microsoft Entra 管理センター(https://aad.portal.azure.com/)
ユーザー＞すべてのユーザー＞プロパティのサブアドレスに登録されている

・ドメインを追加する場合
Microsoft Entra 管理センター(https://aad.portal.azure.com/)
ID＞設定＞ドメイン名＞ドメイン追加
表示されたレコードを設定。

・サブスクリプションを変更する場合
Microsoft 365 管理センター(https://admin.microsoft.com/)
のユーザーから

2023-09-062023-09-06

大量のReturned mailを受信

さくらのレンタルサーバーのメールで、
Returned mail: see transcript for details
を大量に受信しているPCがあった。

急いで、サーバーのコントロールパネルからメールのパスワードを変更する。
次にWebメールのフィルタで、
MAILER-DAEMON
を拒否リストへ追加する。
(大量なのでローカルのOUTLOOKが受信しないように)

しばらくして、
The original message was received at
の部分をみると、新規の送信は止まっているよう。

＊＊＊

The original message was received at メッセージの受信日時
from xxx.xxx.xxx.xxx(送信元/こちら側のアドレス)

—– The following addresses had permanent fatal errors —–
の中に、相手のメールアドレス、失敗の理由(reason)がある
<送信先アドレス>
(reason:エラーコード、ステータスコード、詳細)

<<< 421 4.7.0 Messages from xxx.xxx.xxx.xxx(送信先/エラーコードを返してきたアドレス)

・SMTPのエラーコード
xxx x.x.x
の形式で、先頭4は一般エラーで、先頭5は永続エラー

2023-09-05

VBA ATPVBAEN.XLA

古いエクセルファイルを動かしたら、
Application.Run(“ATPVBAEN.XLA!COMPLEX”, r, q)
の部分でエラーがでた。

XLAMに直せば動かくかと思ったら、駄目だったので、
Application.WorksheetFunction.Complex(r, q)
このように書き換えたら動いた。