2026年01月の記事一覧 | ひできちの楽天ブログ

musicjp の今月（2026/1）の邦画新作のリスト

遅くなりましたが、musicjp の今月（2026/1）の邦画新作のリストを作成しましたので共有しておきますよ2/3 ソートしてみましたよ映画タイトル分類ジャンル特別編集版『機動戦士ガンダム鉄血のオルフェンズウルズハント -小さな挑戦者の軌跡-』アニメSFアズワン/AS ONE アニメアクション・バトル怪盗クイーンの優雅な休暇アニメアクション・バトル劇場版「オーバーロード」聖王国編アニメアクション・バトル劇場版総集編呪術廻戦懐玉・玉折アニメアクション・バトル風都探偵仮面ライダースカルの肖像アニメアクション・バトル遠井さんは青春したい!『バカとスマホとロマンスと』アニメギャグ・コメディ劇場版「僕とロボコ」アニメギャグ・コメディ無名の人生アニメ社会派ルックバックアニメ青春・学園INTER::FACE 知能機械犯罪公訴部 - faith - 映画SFINTER::FACE 知能機械犯罪公訴部 - ペルソナ - 映画SFINTER::FACE 知能機械犯罪公訴部 - 名前のない詩 - 映画SFエターナルラブが蔓延した日映画SFとなりの宇宙人映画SFゴーストキラー映画アクション映画『仮面ライダーガヴお菓子の家の侵略者』映画アクション帰ってきたあぶない刑事映画アクションNOT BEER 映画コメディ映画おっさんのパンツがなんだっていいじゃないか! 映画コメディ映画『ぶぶ漬けどうどす』映画コメディショウタイムセブン映画サスペンス・ミステリーフェイクアウト! 映画サスペンス・ミステリー劇場版『トリリオンゲーム』映画サスペンス・ミステリー正体映画サスペンス・ミステリー法廷の死神第1章映画サスペンス・ミステリー法廷の死神第2章映画サスペンス・ミステリー≠ME THE MOVIE -約束の歌- 映画ドキュメンタリーAqours Documentary 映画ドキュメンタリーThe Taste of Nature Ⅱ 幻のカカオを探して映画ドキュメンタリードクちゃんフジとサクラにつなぐ愛映画ドキュメンタリーファイト映画ドキュメンタリー劇場版クマと民主主義映画ドキュメンタリー巣鴨日記あるBC級戦犯の生涯映画ドキュメンタリー大和の赤子映画ドキュメンタリー凪が灯るころ~奥能登、珠洲の記憶~ 映画ドキュメンタリー満天の星映画ドキュメンタリー映画『ナンバーワン戦隊ゴジュウジャー復活のテガソード』映画ファミリー・子供向け仮面ライダーガヴギルティ・パルフェ映画ファミリー・子供向けあみはおばけ映画ファンタジー映画『僕らは人生で一回だけ魔法が使える』映画ファンタジーカラダ探し THE LAST NIGHT 映画ホラードールハウス映画ホラーほんとにあった!呪いのビデオ114 映画ホラー近畿地方のある場所について映画ホラー劇場版ほんとうにあった怖い話~ゾクッ事故物件芸人~ 映画ホラー見える子ちゃん映画ホラー嗤う蟲映画ホラーむこうぶちRAW 高レート裏麻雀列伝1 卒業映画ヤクザ・マフィアむこうぶちRAW 高レート裏麻雀列伝2 成金前編映画ヤクザ・マフィア極道の紋章レジェンド第二十七章映画ヤクザ・マフィア極道の紋章レジェンド第二十八章映画ヤクザ・マフィア生きない映画ヤクザ・マフィア日本統一69 映画ヤクザ・マフィアROPE 映画社会派・ヒューマンあいもかわらず映画社会派・ヒューマンオンステージ映画社会派・ヒューマンかくかくしかじか映画社会派・ヒューマンノラノコ映画社会派・ヒューマンめためた映画社会派・ヒューマンルート29 映画社会派・ヒューマンルノワール映画社会派・ヒューマン映画『グランメゾン・パリ』映画社会派・ヒューマン桐島です映画社会派・ヒューマン事実無根映画社会派・ヒューマン少年と犬映画社会派・ヒューマン美晴に傘を映画社会派・ヒューマンBADBOYS -THE MOVIE- 映画青春LIBERTY DANCE 映画青春アオショー! 映画青春還暦高校生映画青春私たちのオカルティックサマー映画青春太陽がしょっぱい映画青春長崎ー閃光の影でー映画戦争Life record 映画短編・オムニバスYOUNG&FINE 映画恋愛・ロマンスフィリピンパブ嬢の社会学映画恋愛・ロマンス劇場版彼女のくちづけ感染するリビドー映画恋愛・ロマンス山田くんとLv999の恋をする映画恋愛・ロマンス女神降臨 After プロポーズ編映画恋愛・ロマンス女神降臨 Before 高校デビュー編映画恋愛・ロマンス夜のまにまに映画恋愛・ロマンス隣のステラ映画恋愛・ロマンス

2026/01/31

コメント(0)

musicjp の今月（2026/1）の洋画新作のリスト

月末ですが、musicjp の今月（2026/1）の洋画新作のリストを作成しましたので共有しておきますよ私はmusicjp 有料会員でございまして毎月一カ月間限定の動画専用1500ポイントが付与されるので月末までぎりぎりまで待って配信開始になっている新作から選んで1500ポイント分のレンタルをしたいのですよ忙しいと全くなにもレンタル候補もないまま月末を迎えて23:59ギリギリまで対応しているみたいな状況になっちゃっていますよ今日の夜に邦画の新作の方もリストを作成して共有いたしますよ2/3 ソートしてみましたよ映画タイトル分類ジャンル劇場版スマーフ/おどるキノコ村の時空大冒険(パラレルアドベンチャー)アニメファンタジー塔の上のミーナ姫アニメファンタジーTheアニメ恋愛サバイバル映画SFダイナソー・ワールド映画SFデンジャラス・クイーン映画SFトロン:アレス映画SFドント・フィード・ザ・チルドレン映画SFニーナ映画SFブレス映画SFプレデター:バッドランド映画SFプロジェクト・タイタン映画SFメガロポリス映画SFCHLOE/クロエ映画アクションMr.ノーバディ2映画アクションアンダー・ファイヤー映画アクションインファナル・フィクサー映画アクションキャッシュ:裏社会への反撃映画アクションザ・グリンベレー映画アクションザ・ザ・コルダのフェニキア計画映画アクションスタントマン映画アクションデンジャラス・オーシャン映画アクションフォーミュラ映画アクションブラック・ロータス映画アクションブラックバッグ映画アクションプレイ・ダーティー映画アクションヘッド・オブ・ステイト映画アクションモブ・ランド映画アクションラスト・エージェント映画アクションランド・オブ・バッド映画アクションレッド・ジャスティス映画アクションレッド・ワン映画アクションワン・バトル・アフター・アナザー映画アクション血戦映画アクション三銃士映画アクション三銃士映画アクションおばあちゃんと僕の約束映画コメディグッド・フォーチュン映画コメディシャッフル・フライデー映画コメディディア・サンタ映画コメディフォーチュンクッキー映画コメディローズ家~崖っぷちの夫婦~映画コメディ犬の裁判映画コメディ裸の銃を持つ男(2025)映画コメディFOG映画サスペンス・ミステリーMELT映画サスペンス・ミステリーRED映画サスペンス・ミステリーアナザー・シンプル・フェイバー映画サスペンス・ミステリーザ・コンサルタント2映画サスペンス・ミステリーテレビの中に入りたい映画サスペンス・ミステリーベイビーガール映画サスペンス・ミステリー愛はステロイド映画サスペンス・ミステリー異端者の家映画サスペンス・ミステリー顔を捨てた男映画サスペンス・ミステリー入国審査映画サスペンス・ミステリーガザからの声映画ドキュメンタリーサタンがおまえを待っている映画ドキュメンタリーただ、愛を選ぶこと映画ドキュメンタリームガリッツ映画ドキュメンタリー占領都市映画ドキュメンタリージュラシック・タウン映画パニックディープ・ウォーター映画パニックデッド・フライト~人喰い蜘蛛の巣~映画パニック津波シャーク映画パニックヒックとドラゴン映画ファンタジーヘルボーイ/ザ・クルキッドマン映画ファンタジーアンデッド映画ホラーイマキュレイト聖なる胎動映画ホラーエレベーション映画ホラーシェルビー・オークス映画ホラーダブル・ブラインド映画ホラーデビルズ・バス映画ホラードラウグ映画ホラーブラックフォン映画ホラーブルート映画ホラーラストサマー:リターンズ映画ホラー鬼哭映画ホラー恐怖の幻想映画ホラー狗神の業映画ホラー子鹿のゾンビ映画ホラー死霊館映画ホラー絶対に眠ってはいけない映画ホラー地獄のサマーキャンプ映画ホラージュラシック・ワールド/復活の大地映画割引パルテノペ映画社会派・ヒューマンペンギン・レッスン映画社会派・ヒューマンマリア・モンテッソーリ映画社会派・ヒューマン教皇選挙映画社会派・ヒューマン年少日記映画社会派・ヒューマン親友かよ映画青春サスカッチ・サンセット映画旅・冒険スプリングスティーン映画歴史レーガン~勇敢なる自由の先導者映画歴史#恋愛こじらせ女子、オーハイへ行く映画恋愛・ロマンスマルティネス映画恋愛・ロマンスリグレティング・ユー映画恋愛・ロマンス新世紀ロマンティクス映画恋愛・ロマンス真心を込めて招待します映画恋愛・ロマンス

2026/01/30

コメント(0)

楽天ポイントビットコインまた急落(泣)

楽天ポイントビットコインがまた急落しておりますよ容赦なく下がり続けていますな・・・例によってこんな状況でまた私は結構な額を突っ込んでしまっておりまして・・・・半年の長期で回復するのを待つしかありませんなとほほ・・・

2026/01/30

コメント(0)

ファイル名の先頭に指定文字を付加するバッチとな？

ファイル名の先頭に指定文字を付加する作業は、IT実務でもそうでなくても、ほとんどのケースで必要になると思いますが、その数が多くなると面倒でしかありませんなほとんどの場合、ファイル名の命名規則、なにかしらのルールがあると思いますがバッチファイルで対応可能なのであれば、自動化できますなというわけで、今回はファイル名の先頭に「フォルダー名」を付加するバッチファイルを紹介いたしますよバッチファイルはUTF8に対応していませんがファイル名を変更するだけなら問題はありませんなバッチファイル自体もからなずSJIS(ANSI)で保存してくださいな以下の水平線の中がバッチファイル本体ですよ私は「###renameAddFolder.bat 」このような名前で保存しておりますよ@echo offsetlocal enabledelayedexpansionrem 1.フォルダー配下のファイルに対して、リネーム加工。rem 2.フォルダー名をファイル名の先頭に付加してリネーム。rem 3.対象ファイルは、引数①の文字列で始まるファイルのみ。rem 4.バッチファイルが存在するフォルダーが処理対象のフォルダー。rem 5.引数②：フォルダー名 + 引数②の文字列 + 元ファイル名の形でリネームする@echo offsetlocal enabledelayedexpansionrem 引数1: 対象プレフィックスset "prefix=%~1"rem 引数2: insertset "insert=%~2"rem このバッチがあるフォルダーset "dir=%~dp0"rem フォルダー名を取得for %%A in ("%dir%.") do set "folder=%%~nxA"rem ===== 変数表示 =====echo prefix=%prefix%echo insert=%insert%echo dir=%dir%echo folder=%folder%echo ---------------------------------rem ===== メイン処理 =====for %%F in ("%dir%%prefix%*") do ( set "name=%%~nxF" ren "%%F" "%folder%!insert!!name!")endlocalこのようなファイルに対して、フォルダー名をファイル名に付加したい場合call ###renameAddFolder.bat 楽天CH _とバッチファイルの引数を指定して実行すれば以下のようにリネームしてくれますよちなみにこのバッチは毎日の楽天PLAYに投稿している記事の内容を半自動で作成している作業の一部でございますよ

2026/01/25

コメント(1)

Excelファイルの複数シート操作をするVBAフォームとな？

Excelファイルの複数シート操作をする専用の画面機能をエクセルVBAでつくったら便利だろうと思いましてExcelファイルの複数シート操作をするVBAフォームをAIに依頼して作ってみましたよ実際のフォームの動作はこんな感じこのフォームにExcelファイルを読み込ませるとそのファイルが普通にエクセルで表示されてこのフォームにもシートの一覧が表示されますよフォームからシート操作することでエクセルにも即反映されますよ即保存もするかどうかは指定できるようにしてみましたよシートの操作の機能はいろいろ組み込みたいのですがとりあえず必要性に迫られていた以下を実装しましたよ１．シート一覧表示（リストボックス）２．選択シートをアクティブにする（リストボックス）３．シートの位置の操作（↑↓ボタン）４．シート名の変更（変更ボタン）５．シートコピー（コピーボタン）６．シート見出し色の表示、変更（リストボックス2）リストは単一選択、複数選択、shift /ctrl を使う選択　を切替可能他にもいろいろ考えられるのですがとりあえずということで。コントロール名種類機能ListBox1ListBox外部ブックのシート一覧ListBox2ListBoxシート見出し色名＋HEX値の一覧(２列の定義)cmbSelectModeComboBoxListBox1 の選択モード切替（単一／複数／拡張）cmdOpenBookcommandButtonExcelファイルを開くcmdRenameSheetcommandButton選択シートの名前変更（単一選択のみ）cmdCopySheetcommandButton選択シートのコピー（複数選択対応）cmdMoveUpcommandButton選択シートを上へ移動（複数選択対応）cmdMoveDowncommandButton選択シートを下へ移動（複数選択対応）cmdRefreshcommandButtonシート一覧の最新化（外部ブックの状態を再取得）cmdCloseBookcmd外部ブックを閉じて画面初期化chkSavecheckboxシート操作のあとファイル保存するかどうか'標準モジュールSub シート操作form() UserForm1.Show vbModelessEnd Sub'UserFormDim targetWb As WorkbookDim targetPath As StringPrivate Sub CommandButton1_Click()End SubPrivate Sub UserForm_Initialize() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim colorName As String Dim hexVal As String '----------------------------------------- ' 見出し色定義シートの存在チェック '----------------------------------------- On Error Resume Next Set ws = ThisWorkbook.Worksheets("見出し色定義") On Error GoTo 0 ' なければ作成 If ws Is Nothing Then Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.name = "見出し色定義" ' 初期ヘッダー行 ws.Range("A1").Value = "色名" ws.Range("B1").Value = "HEX" ' 必要なら初期色を入れておく（任意） ws.Range("A2").Value = "赤" ws.Range("B2").Value = "FF0000" ws.Range("A3").Value = "青" ws.Range("B3").Value = "0000FF" End If '----------------------------------------- ' シートから色名とHEXを読み込む '----------------------------------------- lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow ' 1行目は見出し colorName = Trim(ws.Cells(i, "A").Value) hexVal = UCase$(Trim(ws.Cells(i, "B").Value)) ' HEX は必ず6桁 If Len(hexVal) = 6 Then Me.ListBox2.AddItem colorName Me.ListBox2.List(Me.ListBox2.ListCount - 1, 1) = hexVal End If Next i ' --- コンボボックスに選択モードを追加 --- With Me.cmbSelectMode .Clear .AddItem "単一選択" ' MultiSelect = 0 .AddItem "複数選択" ' MultiSelect = 1 .AddItem "拡張選択" ' MultiSelect = 2 .ListIndex = 0 ' 初期値：単一選択 End WithEnd SubPrivate Sub cmdRefresh_Click() If targetWb Is Nothing Then Exit Sub ' シート一覧を最新化 RefreshSheetList ' ついでに現在アクティブなシートを選択状態にする Dim ws As Worksheet Set ws = targetWb.ActiveSheet Dim i As Long For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.List(i) = ws.name Then Me.ListBox1.ListIndex = i Exit For End If Next iEnd SubPrivate Sub cmdOpenBook_Click() Dim fd As FileDialog Dim sh As Worksheet Dim backupPath As String ' ファイル選択 Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "編集するブックを選択してください" .Filters.Clear .Filters.Add "Excel ブック", "*.xlsx; *.xlsm; *.xls" If .Show <> -1 Then Exit Sub targetPath = .SelectedItems(1) End With' ' バックアップ作成（可逆性の確保）' backupPath = targetPath & ".bak_" & Format(Now, "yyyymmdd_hhnnss")' FileCopy targetPath, backupPath ' 書き込み可能で開く Set targetWb = Workbooks.Open(Filename:=targetPath, ReadOnly:=False) ' ListBox 初期化 Me.ListBox1.Clear ' シート名を追加 For Each sh In targetWb.Worksheets Me.ListBox1.AddItem sh.name Next shEnd SubPrivate Sub RefreshSheetList() Dim sh As Worksheet Me.ListBox1.Clear For Each sh In targetWb.Worksheets Me.ListBox1.AddItem sh.name Next shEnd SubPrivate Sub cmdCopySheet_Click() Dim shName As String Dim ws As Worksheet If Me.ListBox1.ListIndex = -1 Then MsgBox "シートを選択してください", vbExclamation Exit Sub End If CopySelectedSheets If chkSave.Value = True Then ' 自動保存 targetWb.Save End IfEnd SubPrivate Sub cmdDown_Click() Dim idx As Long Dim ws As Worksheet Dim last As Long If Me.ListBox1.ListIndex = -1 Then MsgBox "シートを選択してください", vbExclamation Exit Sub End IfMoveDown If chkSave.Value = True Then ' 自動保存 targetWb.Save End IfEnd SubPrivate Sub cmdRename_Click() Dim idx As Long Dim ws As Worksheet Dim newName As String If Me.ListBox1.ListIndex = -1 Then Exit Sub idx = Me.ListBox1.ListIndex + 1 Set ws = targetWb.Worksheets(idx) ' InputBox で新しいシート名を取得 newName = InputBox("新しいシート名を入力してください", "シート名変更", ws.name) ' キャンセル or 空文字なら何もしない If newName = "" Then Exit Sub ' シート名変更 On Error Resume Next ws.name = newName If Err Then MsgBox "既に使用されている名前です", vbCritical + vbOKOnly Exit Sub End If If chkSave.Value = True Then ' 自動保存 targetWb.Save End If ' シート一覧更新 RefreshSheetList ' 変更後のシートを再選択 Me.ListBox1.ListIndex = idx - 1End SubPrivate Sub cmdUp_Click() Dim idx As Long Dim ws As Worksheet If Me.ListBox1.ListIndex = -1 Then MsgBox "シートを選択してください", vbExclamation Exit Sub End IfMoveUp If chkSave.Value = True Then ' 自動保存 targetWb.Save End IfEnd SubPrivate Sub cmdCloseBook_Click() ' targetWb がセットされていなければ何もしない If targetWb Is Nothing Then Exit Sub ' 保存して閉じる（保存不要なら Save を削除） targetWb.Close SaveChanges:=True ' 参照を破棄 Set targetWb = Nothing ' フォームの表示内容をクリア Me.ListBox1.Clear Me.ListBox2.ListIndex = -1 ' 必要なら他の UI も初期化 ' 例：ラベルやテキストボックスを空にする ' Me.lblSheetName.Caption = ""End SubPrivate Sub ListBox1_Change() Dim idx As Long Dim ws As Worksheet Dim c As Variant Dim hexVal As String Dim i As Long Dim found As Boolean If targetWb Is Nothing Then Exit Sub If Me.ListBox1.ListIndex = -1 Then Exit Sub idx = Me.ListBox1.ListIndex + 1 Set ws = targetWb.Worksheets(idx) ws.Activate c = ws.Tab.Color If IsNull(c) Then Me.ListBox2.ListIndex = -1 Exit Sub End If hexVal = RGBToHex6(c) found = False For i = 0 To Me.ListBox2.ListCount - 1 If Me.ListBox2.List(i, 1) = hexVal Then ' 2列目のHEXと比較 Me.ListBox2.ListIndex = i found = True Exit For End If Next i If Not found Then Me.ListBox2.AddItem hexVal Me.ListBox2.List(Me.ListBox2.ListCount - 1, 1) = hexVal Me.ListBox2.ListIndex = Me.ListBox2.ListCount - 1 End IfEnd SubPrivate Sub cmdColorChange_Click() Dim idx As Long Dim ws As Worksheet Dim hexVal As String Dim c As Long If targetWb Is Nothing Then Exit Sub If Me.ListBox1.ListIndex = -1 Then Exit Sub If Me.ListBox2.ListIndex = -1 Then Exit Sub hexVal = Me.ListBox2.List(Me.ListBox2.ListIndex, 1) Call ChangeSheetColor(hexVal) If chkSave.Value = True Then ' 自動保存 targetWb.Save End IfEnd SubPrivate Sub cmbSelectMode_Change() Select Case Me.cmbSelectMode.ListIndex Case 0 Me.ListBox1.MultiSelect = 0 ' 単一選択 Case 1 Me.ListBox1.MultiSelect = 1 ' 複数選択（チェックボックス風） Case 2 Me.ListBox1.MultiSelect = 2 ' 拡張選択（Ctrl/Shift） End SelectEnd SubPrivate Function GetSelectedSheets() As Collection Dim Col As New Collection Dim i As Long For i = 0 To Me.ListBox1.ListCount - 1 If Me.ListBox1.Selected(i) Then Col.Add Me.ListBox1.List(i) End If Next i Set GetSelectedSheets = ColEnd FunctionPrivate Function SetSelectedSheets(Col As Collection) Dim n As String For i = 0 To Me.ListBox1.ListCount - 1 n = ListBox1.List(i) For j = 1 To Col.Count If Col(j) = n Then Me.ListBox1.Selected(i) = True End If Next NextEnd FunctionPrivate Sub ChangeSheetColor(hexVal As String) If targetWb Is Nothing Then Exit Sub Dim Col As Collection Dim name As Variant Dim c As Long Set Col = GetSelectedSheets() If Col.Count = 0 Then Exit Sub c = Hex6ToRGB(hexVal) For Each name In Col targetWb.Worksheets(name).Tab.Color = c Next name SetSelectedSheets Col End SubPrivate Sub CopySelectedSheets() If targetWb Is Nothing Then Exit Sub Dim Col As Collection Dim name As Variant Set Col = GetSelectedSheets() If Col.Count = 0 Then Exit Sub For Each name In Col targetWb.Worksheets(name).Copy After:=targetWb.Worksheets(name) Next name ' シート一覧更新 RefreshSheetList SetSelectedSheets ColEnd SubPrivate Sub MoveUp() If targetWb Is Nothing Then Exit Sub Dim Col As Collection Dim name As Variant Dim ws As Worksheet Set Col = GetSelectedSheets() If Col.Count = 0 Then Exit Sub Dim i As Long For i = 1 To Col.Count Set ws = targetWb.Worksheets(Col(i)) If ws.Index > 1 Then ws.Move Before:=targetWb.Worksheets(ws.Index - 1) End If Next i ' シート一覧更新 RefreshSheetList SetSelectedSheets ColEnd SubPrivate Sub MoveDown() If targetWb Is Nothing Then Exit Sub Dim Col As Collection Dim name As Variant Dim ws As Worksheet Set Col = GetSelectedSheets() If Col.Count = 0 Then Exit Sub Dim i As Long For i = Col.Count To 1 Step -1 Set ws = targetWb.Worksheets(Col(i)) If ws.Index < targetWb.Worksheets.Count Then ws.Move After:=targetWb.Worksheets(ws.Index + 1) End If Next i ' シート一覧更新 RefreshSheetList SetSelectedSheets ColEnd SubPrivate Function RGBToHex6(c As Variant) As String Dim r As Long, g As Long, b As Long r = c Mod 256 g = (c \ 256) Mod 256 b = (c \ 65536) Mod 256 RGBToHex6 = Right$("0" & Hex(r), 2) & Right$("0" & Hex(g), 2) & Right$("0" & Hex(b), 2)End FunctionPrivate Function Hex6ToRGB(hexStr As String) As Long Dim r As Long, g As Long, b As Long hexStr = Replace(hexStr, "#", "") hexStr = UCase$(hexStr) r = CLng("&H" & Mid$(hexStr, 1, 2)) g = CLng("&H" & Mid$(hexStr, 3, 2)) b = CLng("&H" & Mid$(hexStr, 5, 2)) Hex6ToRGB = RGB(r, g, b)End Function後でこのマクロExcelファイルをダウンロードできるようにしますがそれよりもソースコードの方がなければ話にならないと思いますので以上となりますよ

2026/01/25

コメント(0)

Excelで他のシートの値と一致しているかどうかを検査する計算式とな？

Excelで他のシートの値と一致しているかどうかを検査する計算式があれば便利なのですが簡単に作れそうな感じじゃないのでAIに依頼してみましたよ=LET( currentCell, B9, fromSuffix, "A", toSuffix, "B", fullName, CELL("filename", currentCell), sheetName, MID(fullName, FIND("]", fullName) + 1, 255), targetSheet, SUBSTITUTE(sheetName, fromSuffix, toSuffix), targetCell, targetSheet & "!" & CELL("address", currentCell), IF(currentCell = INDIRECT(targetCell), "○", "×"))B9 は検査対象の範囲の左上セルです。検査結果を〇×で表示する表を別に表示したいこの式は、そういう用途で使う想定です検査結果の表の左上セルにこの式を設定すれば〇×表示してくれますのであとは検査結果の表全体に対して数式だけ範囲コピーすれば完成となりますなシートAとシートBの比較をしますがそれだと応用性がなくて、利用価値もないのでシート名：アジア_日本シート名：アジア_中国　（日本と中国の比較）シート名：アジア_韓国　（日本と韓国の比較）シート名：アジア_タイ　（日本とタイの比較）こういう比較を簡単にできるようにするためA="日本" B="中国　とlet式の定義の中で比較対象シートを緩く定義できるようにしてみましたよシート名としてはこのような、一部（後半部分）がだけが違っていてるみたいなルールで作ってるんじゃないかと思ったので。なお、比較するシートの検査する範囲は当然ですが比較先、比較元、セル位置としては完全一致しているという前提ですよ

2026/01/23

コメント(0)

CSVデータのチェック機能とな？

VBAの続きですよinsert文作っても、データ属性違反なデータがあるとSQL実行エラーになってしまいますのでチェック機能を作ってもらいましたよSub ValidateDataAndCreateSQL() Dim ws As Worksheet Dim lastCol As Long Dim lastRow As Long Dim i As Long, j As Long Dim colName As String Dim dataType As String Dim notNull As String Dim maxLen As Long Dim cellValue As String Dim errorMsg As String Dim hasError As Boolean Set ws = ActiveSheet '--- カラム数・行数 --- lastCol = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row '--- まず 9 行目のエラー表示セルをクリア --- For j = 1 To lastCol ws.Cells(9, j).Value = "" Next j hasError = False '=========================================================== ' バリデーション処理 '=========================================================== For j = 1 To lastCol colName = Trim(ws.Cells(3, j).Value) dataType = UCase(Trim(ws.Cells(4, j).Value)) notNull = UCase(Trim(ws.Cells(5, j).Value)) maxLen = Val(ws.Cells(6, j).Value) errorMsg = "" '--- データ行は 12 行目以降 --- For i = 12 To lastRow cellValue = Trim(ws.Cells(i, j).Value) '=========================== ' NOT NULL チェック '=========================== If notNull = "NOT NULL" Then If cellValue = "" Then errorMsg = "notNull違反" hasError = True Exit For End If End If '=========================== ' サイズ長チェック '=========================== If maxLen > 0 Then If Len(cellValue) > maxLen Then errorMsg = "サイズ長違反" hasError = True Exit For End If End If Next i '--- エラーがあれば 9 行目に出力 --- If errorMsg "" Then ws.Cells(9, j).Value = errorMsg End If Next j '=========================================================== ' エラーがあれば SQL 生成を中止 '=========================================================== If hasError Then MsgBox "データに違反があります。9行目のエラー内容を確認してください。", vbExclamation Exit Sub End If '=========================================================== ' ここから先は SQL 生成処理（既存のロジックを呼び出す） '=========================================================== Call CreateInsertSQL ' ← 既に作成済みの SQL 生成サブルーチンを呼ぶEnd Sub

2026/01/22

コメント(0)

ExcelシートのテーブルデータをSQLInsert文ファイルに変換とな？

Excelシートのテーブルデータを元にして、SQLInsert文ファイルを作成してそれを実行する事でデータインポート作業の代わりとしたいという一件、なぜそんなことをわざわざ？と思われるような内容ですがCopilot AIに依頼して作ってもらいましたよSub CreateInsertSQL() Dim ws As Worksheet Dim tableName As String Dim outputPath As String Dim truncateFlag As String Dim lastRow As Long Dim lastCol As Long Dim colNames As String Dim sql As String Dim i As Long, j As Long Dim recordValues As String Dim cellValue As String Dim stm As Object 'ADODB.Stream Set ws = ActiveSheet '--- 基本情報 --- tableName = Trim(ws.Range("B1").Value) outputPath = Trim(ws.Range("B2").Value) truncateFlag = LCase(Trim(ws.Range("B4").Value)) '--- カラム数・行数 --- lastCol = ws.Cells(8, ws.Columns.Count).End(xlToLeft).Column lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row '--- カラム名 --- colNames = "" For j = 1 To lastCol colNames = colNames & ws.Cells(8, j).Value & ", " Next j colNames = Left(colNames, Len(colNames) - 2) '--- SQL 開始 --- sql = "" If truncateFlag = "truncate" Then sql = sql & "TRUNCATE TABLE " & tableName & ";" & vbCrLf & vbCrLf End If sql = sql & "INSERT INTO " & tableName & " (" & colNames & ") VALUES" & vbCrLf '--- レコード生成 --- For i = 9 To lastRow recordValues = "(" For j = 1 To lastCol cellValue = Trim(ws.Cells(i, j).Value) If cellValue = "" Then recordValues = recordValues & "NULL, " Else recordValues = recordValues & "'" & Replace(cellValue, "'", "''") & "', " End If Next j recordValues = Left(recordValues, Len(recordValues) - 2) recordValues = recordValues & ")," sql = sql & recordValues & vbCrLf Next i sql = Left(sql, Len(sql) - 3) & ";" & vbCrLf '=========================================================== ' UTF-8（BOMなし）でファイル出力（ADODB.Stream） '=========================================================== Set stm = CreateObject("ADODB.Stream") stm.Type = 2 'Text stm.Charset = "UTF-8" 'UTF-8 指定 stm.Open stm.WriteText sql stm.Position = 0 stm.SaveToFile outputPath, 2 '2 = adSaveCreateOverWrite stm.Close MsgBox "INSERT SQLファイル作成が完了しました。", vbInformationEnd SubTRUNCATE TABLE SNOFLAKE.SHCHEMA.TABLEA;INSERT INTO SNOFLAKE.SHCHEMA.TABLEA (col1, col2, col3, col4, col5) VALUES('1', 'tset2', '2026/01/22', NULL, '1234567890123456789012345678901234567890'),('2', 'テスト', '2026/01/20', NULL, '123456789');

2026/01/22

コメント(0)

VBAのUserForm をサイズ可変にするとな？

ExcelでVBAのUserForm はやっぱりサイズ可変にしたくなりますなAI に実装させてみたものをそのまま貼っただけなので動作するかどうかわかりませんが・・・標準モジュール’----------------------------------------------------------------Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtrPublic Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" _ (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtrPublic Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, _ ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtrPublic Const GWL_WNDPROC As Long = -4Public Const WM_MOUSEWHEEL As Long = &H20APublic OldProc As LongPtrPublic UFhWnd As LongPtrPublic Function WindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, _ ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr If uMsg = WM_MOUSEWHEEL Then If UserForm1.ListBox1.ListIndex < UserForm1.ListBox1.ListCount - 1 And wParam < 0 Then UserForm1.ListBox1.ListIndex = UserForm1.ListBox1.ListIndex + 1 ElseIf UserForm1.ListBox1.ListIndex > 0 And wParam > 0 Then UserForm1.ListBox1.ListIndex = UserForm1.ListBox1.ListIndex - 1 End If End If WindowProc = CallWindowProc(OldProc, hWnd, uMsg, wParam, lParam)End FunctionUserForm 初期化でフック’----------------------------------------------------------------Private Sub UserForm_Initialize() UFhWnd = FindWindow("ThunderDFrame", Me.Caption) OldProc = SetWindowLongPtr(UFhWnd, GWL_WNDPROC, AddressOf WindowProc)End Sub● UserForm 終了で解除’----------------------------------------------------------------Private Sub UserForm_Terminate() SetWindowLongPtr UFhWnd, GWL_WNDPROC, OldProcEnd Sub

2026/01/20

コメント(0)

Ecxel for Web　のファイルサイズ上限100MB とな？

Ecxel for Web　で開けるファイルサイズには上限があり100MB までとなっておりますな実際にファイルサイズを30M→70M→100Mと大きくしていって確かめましたよなのですが・・・・楽天ドライブにはExcelの容量25MBまでという記述がみつかるのですが一体なんの話をしているのでしょうかね？https://support.rakuten-drive.com/hc/en-us/articles/24894339899545-How-to-edit-MS-Office-documents-from-Rakuten-Drive楽天ドライブによるとPowerPoint ファイルは100Mを超えてWeb版で表示できるということらしいのでそれについてはまた後で試してみたいと思いますよhttps://support.microsoft.com/ja-jp/office/sharepoint-%E3%81%A7%E3%81%AE%E3%83%96%E3%83%83%E3%82%AF%E3%81%AE%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB-%E3%82%B5%E3%82%A4%E3%82%BA%E3%81%AE%E5%88%B6%E9%99%90-9e5bc6f8-018f-415a-b890-5452687b325e?utm_source=copilot.comExcelの100MB制限はこのページではっきりと書かれておりますがこのページの内容はあくまでExcelについてですなMSはPPTについてはファイルサイズ制限をしているかどうか？確認してまたブログ投稿します

2026/01/20

コメント(0)

ExcelシートにCSVファイルを読み込むVBA

ExcelシートにCSVファイルを読み込むVBA　コードです。もちろんExcel標準機能で可能なんですがマウスワンクリックで終わらせたいと思ったのでCopilot AIに実装させました要件・UTF8ファイルに対応・ファイル名、フォルダーパスはアクティブシートのセルの情報を使用するファイル名→A1フォルダーパス→C1・読み込んだCSVの表示開始位置は、８行目（A８セル）からとする・文字の"00001"が勝手に数字に変換されないこと出来上がったソースコードは遅いですがちゃんと動作していますな処理が遅すぎますがデータ量が少量ならば使えると思いますぞ’----------------------------------------------------------------Sub ImportCSV_UTF8_RFC4180_A8() Dim folder As String Dim fname As String Dim fullpath As String Dim txt As String Dim lines() As String Dim r As Long Dim cols As Variant Dim line As Variant Dim ws As Worksheet Set ws = ThisWorkbook.ActiveSheet folder = ws.Range("C1").Value fname = ws.Range("A1").Value & ".csv" fullpath = folder & "\" & fname '--- UTF-8 テキストとして読み込み（ADODB.Stream 使用）--- txt = ReadTextFileUTF8(fullpath) 'ファイルが空 or 読めなかった場合は終了 If Len(txt) = 0 Then Exit Sub '--- 改行コードを統一 --- txt = Replace(txt, vbCrLf, vbLf) txt = Replace(txt, vbCr, vbLf) lines = Split(txt, vbLf) '--- A8 から表示 --- r = 8 For Each line In lines If Len(line) > 0 Then cols = ParseCSV(CStr(line)) Dim c As Long For c = LBound(cols) To UBound(cols) With ws.Cells(r, c + 1) .NumberFormat = "@" .Value = cols(c) End With Next r = r + 1 End If NextEnd Sub'===========================================================' UTF-8 テキスト読み込み（ADODB.Stream 使用）'===========================================================Function ReadTextFileUTF8(ByVal path As String) As String Dim stm As Object Dim txt As String Set stm = CreateObject("ADODB.Stream") With stm .Type = 2 'text .Charset = "UTF-8" .Open .LoadFromFile path txt = .ReadText .Close End With ReadTextFileUTF8 = txtEnd Function'===========================================================' RFC4180 準拠 CSV パーサ（ダブルクォート完全対応）'===========================================================Function ParseCSV(ByVal s As String) As Variant Dim result() As String Dim buf As String Dim i As Long, ch As String Dim inQuote As Boolean Dim idx As Long ReDim result(0) buf = "" inQuote = False idx = 0 For i = 1 To Len(s) ch = Mid$(s, i, 1) If ch = """" Then If inQuote And Mid$(s, i + 1, 1) = """" Then buf = buf & """" i = i + 1 Else inQuote = Not inQuote End If ElseIf ch = "," And Not inQuote Then result(idx) = buf idx = idx + 1 ReDim Preserve result(idx) buf = "" Else buf = buf & ch End If Next result(idx) = buf ParseCSV = resultEnd Function’----------------------------------------------------------------Sub ImportCSV_UTF8_RFC4180_A8() Dim folder As String Dim fname As String Dim fullpath As String Dim f As Integer Dim bin As String Dim txt As String Dim lines() As String Dim r As Long Dim cols As Variant folder = Range("C1").Value fname = Range("A1").Value & ".csv" fullpath = folder & "\" & fname '--- UTF-8 読み込み --- f = FreeFile Open fullpath For Binary As #f bin = Space$(LOF(f)) Get #f, , bin Close #f txt = StrConv(bin, vbUnicode) '--- 改行コードを統一 --- txt = Replace(txt, vbCrLf, vbLf) txt = Replace(txt, vbCr, vbLf) lines = Split(txt, vbLf) '--- A8 から表示 --- r = 8 Dim line As Variant For Each line In lines If Len(line) > 0 Then '★ RFC4180 CSV パース（ダブルクォート対応） cols = ParseCSV(line) Dim c As Long For c = LBound(cols) To UBound(cols) With Cells(r, c + 1) .NumberFormat = "@" .Value = cols(c) End With Next r = r + 1 End If NextEnd Sub'===========================================================' RFC4180 準拠 CSV パーサ（ダブルクォート完全対応）'===========================================================Function ParseCSV(ByVal s As String) As Variant Dim result() As String Dim buf As String Dim i As Long, ch As String Dim inQuote As Boolean Dim idx As Long ReDim result(0) buf = "" inQuote = False idx = 0 For i = 1 To Len(s) ch = Mid$(s, i, 1) If ch = """" Then If inQuote And Mid$(s, i + 1, 1) = """" Then buf = buf & """" i = i + 1 Else inQuote = Not inQuote End If ElseIf ch = "," And Not inQuote Then result(idx) = buf idx = idx + 1 ReDim Preserve result(idx) buf = "" Else buf = buf & ch End If Next result(idx) = buf ParseCSV = resultEnd Function’----------------------------------------------------------------Sub ImportCSV_UTF8_NoGarble_KeepLeadingZeros() Dim folder As String Dim fname As String Dim fullpath As String Dim f As Integer Dim txt As String Dim lines() As String Dim line As Variant Dim r As Long, c As Long Dim cols() As String folder = Range("C1").Value fname = Range("A1").Value & ".csv" fullpath = folder & "\" & fname 'UTF-8 読み込み（Excelに任せない） f = FreeFile Open fullpath For Binary As #f txt = Space$(LOF(f)) Get #f, , txt Close #f 'UTF-8 → Unicode 変換（文字化け防止） txt = StrConv(txt, vbUnicode) '行分割 lines = Split(txt, vbCrLf) '★ 表示開始行を A8 に変更 r = 8 For Each line In lines If Len(line) > 0 Then cols = Split(line, ",") For c = 0 To UBound(cols) '★ 先頭ゼロ保持のためテキスト形式を強制 With Cells(r, c + 1) .NumberFormat = "@" .Value = cols(c) End With Next r = r + 1 End If NextEnd Sub’----------------------------------------------------------------Sub ImportCSV_UTF8_AsText_Safe() Dim folder As String Dim fname As String Dim fullpath As String Dim wbCSV As Workbook folder = Range("C1").Value fname = Range("A1").Value & ".csv" fullpath = folder & "\" & fname 'UTF-8 で CSV を別ブックとして開く（既存セルは絶対に壊れない） Workbooks.OpenText _ Filename:=fullpath, _ Origin:=65001, _ DataType:=xlDelimited, _ Comma:=True, _ TextQualifier:=xlTextQualifierDoubleQuote, _ FieldInfo:=Array(1, 2) '全列テキスト Set wbCSV = ActiveWorkbook 'A6 以降を更新（A1〜A5 は絶対に触らない） ThisWorkbook.ActiveSheet.Range("A6").Resize( _ wbCSV.Sheets(1).UsedRange.Rows.Count, _ wbCSV.Sheets(1).UsedRange.Columns.Count _ ).Value = wbCSV.Sheets(1).UsedRange.Value 'CSV ブックを閉じる wbCSV.Close FalseEnd Sub

2026/01/19

コメント(0)

クラウド・ストレージの活用方法

私が有料のクラウド・ストレージを契約して使ってみてわかった活用方法を挙げてますよ・Excel for Web版は最強ですよ無料のクラウドスペースでもExcel for Web版は使えますよさらに暗号化したエクセルファイルを使えば最強のセキュリティが得られますよExcelの暗号化はブラウザ内で処理されるZipファイルのAES暗号なのでクラウドサーバーには完全に暗号化されたファイルだけがアップロードされますぞサーバーにはパスワードは送信されないのですよこれは例えサーバー管理者であってもユーザーが暗号化したエクセルファイルの内容は一切確認できないということが保証されるのですよ楽天ドライブはクラウドのEXcelファイルをブラウザでプレビューできますがその画面からボタン１クリックだけでExcelファイルを編集できるExcel for Web版の画面も利用できますよ自動保存ですから何も意識することはありませんよこのあたりの機能は各サービスによって差がありますなInfiniCloud、TeraBox はプレビューすらできませんFeBox はプレビューのみGoogle Driveは当然編集可能ですが以下の制限ありますぞさらにExcel for Web版で暗号化したExcel ファイルに画像をはれば画像もzip暗号化されるので画像を見られてしまう可能性をゼロにできますよめちゃめちゃ便利ですよクラウドスペースの規約には管理のため必要に応じてデータを確認すると明記されてますからね例えば楽天ドライブがそうなんですが・・・というかhttps://home.rakuten-drive.com/privacy?lang=ja5. 個人情報の保管場所・アクセス権者・国外への移転当社は韓国法人であるため、お客様の個人情報およびアップロードデータを、当社の事業活動を通じて、大韓民国所在の当社従業員が取り扱うことがあります。ほとんどのクラウドサービスがこういう規約になっていますけどとにかくクラウドのデータは検閲される前提で利用した方がいいわけですなそんなクラウドサービスを使っていても暗号化したエクセルファイルに文書、画像を管理しておけばその中の個人情報は保護できますよパスワードは８文字以上あれば十分ですが推測されない文字列にしてくださいななお、Excelには25Mまで画像ファイルを貼れますよ暗号化したエクセルに画像を貼れば画像も自動的に暗号化されてクラウドに保存されますので暗号化する手間が全くかかりませんよ㊙な画像を完全にローカルから削除してしまってクラウドで管理しながらであっても強固な暗号化と十分な複雑さと長さのパスワードで誰にも見られないようにできますよGoogle Driveは暗号化したExcelファイルには対応できていないようですなアップロードするとエラーになってしまいますなMSのOnDriveは当然問題なしですな暗号化したExcel ファイルのExcel for Web版での編集作業となると機能として提供されているのは楽天ドライブ、MSのOnDrive　くらいになりますかね？・クラウドにmp3を置くのも最強ですよmp3はサイズ小さいですしアップロードに時間かからないですからどんどんおいていきましょうそしてローカルドライブにマウントするフリーソフトがありますAir Live Drive Basic　製品情報RaiDrive - USB ドライブのようにクラウドストレージをマウントするこれらを使ってクラウドのmp3をローカルファイルとしてVLCなどの高機能プレーヤーで再生しましょうローカルからmp3を完全に排除しつつクラウドサービスの貧弱なmp3再生機能に縛られることもなくベストな音楽再生環境を構築できますよただしクラウドストレージ側がWEBDAVに対応している必要がありまして無料でWEBDAVを提供しているクラウドはInfini Cloud がありますなInfini Cloud は20GB 無料で使えますからmp3ファイルの置き場としては十分使えるんじゃないでしょうか？オープンソースのベストなプレイヤー VLCメディアプレイヤーのオフィシャルダウンロードです。 - VideoLAN文書、画像、音楽ファイルときたら、次は動画ですなこれはまた記事を分けて投稿いたしますよ

2026/01/10

コメント(0)