常連

古いDBからExcelVBAでExcelにレコードを書き込むツールを作ってみたのですが、かなり重く悪戦苦闘しています。

現場のプロのみなさんはどう対応されてるかお伺いしたいです。

【状況】
2005年に作成されたAccess2000形式の拡張子「.mdb」のデータベースで、再構築した方が早そうなのは重々承知なのですが、他部署の営業が使ってるということでDBの再構築が叶わない状況です。
※Accessは32bitの2019版。win10の32bit。共有ドライブ上での使用。
※自身は1部署の効率化ツールを作成するために派遣で常駐しています

【ExcelVBA実行時の状況】
・初回の実行が4，5分かかります。しかし、2回目以降は数秒で該当のレコードをExcelシートに書き出すことができます。

・上記はaccessを開いた状態です。開いていないと、2回目以降も遅いです。アクセスを開いてクエリ実行完了までに5分くらいかかります。

【なぜ、実行準備が整うまで時間がかかるツールを使うのか】
2回目以降は数秒で取得できるため、処理件数（Excelのリストシート）が多いほど手動でやるよりも早く終わるからです。
※該当の顧客レコードを取得し、整形・加工して印刷とPDF保存を行うツールです

【ExcelVBA側のドライバ】
AIに聞いたところ、12.0の方がいいよってことなので、それを使ってます。
AI「Microsoft.Jet.OLEDB.4.0 は公式にはサポート終了しているため、可能であれば Microsoft.ACE.OLEDB.12.0 を使うのが推奨されます。
32bit 環境でも、Access Database Engine 2010 (32bit版) をインストールすれば、以下のように ACE.OLEDB.12.0 を使うことができます。」

【やってみたこと】
DBの最適化のみ（無駄クエリ、無駄テーブル等の削除行為は他部署のツールだからできない）

【DBの様態】
実際にデータが入っているDBと、フォームがあるDB（リンクテーブル）は分割されている

【知りたいこと】
経験豊富なプロの方たちはもし上記の状況だった場合、どうされますか？？
この状況は詰んでいますでしょうか？
これ以上やりようが無いか確かめたく質問させていただきました。

【上記の状況を要約】
勝手にDB再構築できない、レポートのレイアウトや、フォームの機能変更はできない。レコードを取得するのみならず更新作業もある。でも、事務作業に時間とられたくないから何とかならないかという依頼を受けている。




20年前に作られた古いAccessDBについて

### 実現したいこと
accdb(正確にはaccdr)ファイル(➀とする)からテーブルをCSVへエクスポートし、別のaccdbファイル(②とする)でそのCSVファイルをインポートしたい。

### 発生している問題・分からないこと
①で、テーブルが更新される度に「DoCmd.TransferText」メソッドでテーブルをCSVにエクスポートしている。
②でCSVファイルを既存テーブルにインポートしようとした時に日付/時刻型の列のインポートが失敗していてNULLになっていることがあり、その時にCSVファイルを確認してみると、エクスポートされた日付/時刻型の列の値がおかしな値になっている。

### エラーメッセージ
```error
エラーメッセージ等は特にないので、エクスポートされた日付/時刻型の列の値の例を記載します。

正しく出力された場合の値　　　おかしな形になっている時の値
「2025/05/02 19:10:00」　　「2025/05/02 '('022')' 19:10:00」
「2025/05/03 13:15:00」　　「2025/05/03 '('033')' 13:15:00」
「2025/05/18 9:20:00」　　  「2025/05/18 '('1818')' 9:20:00」

日付と時刻の間に、日付の「日」部分を二回繰り返したような文字列とシングルクォーテーション・カッコが出力されているという点が共通しています。発生した時は、該当CSVファイル内の全ての日付型の列の全ての値がこうなります。
また、日付と時刻の間の謎の文字列は、シングルクォーテーション・カッコがなく数字3桁もしくは4桁のみのパターンもあります。。。
```

### 該当のソースコード

```Access VBA
DoCmd.TransferText acExportDelim, , "テーブル名, "パス.csv", True
'「テーブル名」、「パス」は質問用の仮名、正しくテーブル名・パスは指定されています
```

### 試したこと・調べたこと
- [x] teratailやGoogle等で検索した
- [x] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [x] その他

##### 上記の詳細・結果
・Web検索では同じような例が見つかりませんでした。
・上記ソースコード実行時に、必ずしも該当のおかしな値になるとは限らず、普通に出力できることの方が多いです。再現性が無く、該当のおかしな値が出力される時の条件が分かっていません。


### 補足
①のファイルでのソースコード実行環境は別の者の環境で、「Microsoft 365 Access Runtime」を使用して①のaccdrファイルを開いて実行されています。

Access VBAでテーブルをCSVへエクスポート時、日付型の列に謎の値が入ることがある

### 実現したいこと
Excelのデータリストから、各条件にあった行を新規シートに抽出したい

### 発生している問題・分からないこと
新規シートは作成できているが、ヘッダーのみしか表示されない
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2025-05-31/208d767b-a359-4412-b5b4-834866d014ef.jpeg)
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2025-05-31/2bda154f-993b-4298-9406-022ed8e61c44.jpeg)

### エラーメッセージ
```error
エラーはありませんが、結果が違います
```

### 該当のソースコード

```python
import openpyxl
import os

# Excelファイルのパス
file_path = r"C:\Users\ozawa\Documents\python練習コード.xlsx"

# ファイルの存在を確認
if not os.path.exists(file_path):
    print(f"エラー: ファイル '{file_path}' が存在しません。")
    exit()

try:
    # 読み込み
    workbook = openpyxl.load_workbook(file_path)

    # コピー元シートの取得
    source_sheet = workbook["データ一覧"] # シート名は必要に応じて変更

    # コピー先シートの作成
    if "抽出結果" not in workbook.sheetnames:
        target_sheet = workbook.create_sheet("抽出結果")
        header = [cell.value for cell in source_sheet[1]] # ヘッダー行をコピー
        target_sheet.append(header)
    else:
        target_sheet = workbook["抽出結果"]
        if target_sheet.max_row == 0:
            header = [cell.value for cell in source_sheet[1]]
            target_sheet.append(header)


            data9_value = row[10].value # 目的 (11列目)

            # data9が空白の場合に9を設定
            if data9_value is None or str(data9_value).strip() == "":
                data9 = 9
            else:
                try:
                    data9 = int(data9_value)
                except ValueError:
                    data9 = 0 # 数値に変換できない場合は0を設定

            data4 = row[4].value #  (5列目)
            data7 = row[8].value #  (9列目)

            # 値を数値に変換 (エラー処理付き)
            data8 = row[9].value #  (10列目)

            if data8 is None or str(data8_value).strip() == "":
                data8 = 9
            else:
                try:
                    data8 = int(data8_value)
                except ValueError:
                    data8 = 0 # 数値に変換できない場合はスキップ

            if data7 is None or str(data7).strip() == "":
                data7 = 9
            else:
                try:
                    data7 = int(data7)
                except ValueError:
                    data7 = 0
                    
            # 条件に合致する行を抽出
            if data9 == 1 and data4 == 1 and data7 == 15001 and data9 == 15001:
                for i, value in enumerate(values): # enumerateを使ってindexを取得
                    target_sheet.cell(row=row_num, column=i + 1).value = value
                row_num += 1

    # 保存
    workbook.save(file_path)

    print("抽出とコピーが完了しました。")

except KeyError as e:
    print(f"エラー: シート '{e}' が存在しません。")
except Exception as e:
    print(f"予期せぬエラー: {e}")
```

### 試したこと・調べたこと
- [ ] teratailやGoogle等で検索した
- [x] ソースコードを自分なりに変更した
- [x] 知人に聞いた
- [ ] その他

##### 上記の詳細・結果
自分になりにGeminiを使って修正したりして、エラー表示はなくなりましたが、ヘッダーのみしか表示されませんでした

### 補足
どんなコードであれば、キチンと実行できるのかも知りたいです.
よろしくお願いします

Pythonコードを実行しても思い通りにならない

### 実現したいこと
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2025-04-23/7f0f9e60-9917-45a5-8624-97d63df276fd.png)

大項目ごとの合計数字を代入したい。該当する列に。
添付の画像の①30行目と②40行目のカテゴリー別の合計行に、①には、23行目と29行目の小項目の合計を、②には、33行目と39行目の小項目の合計を該当する列に代入したい。
小項目の合計だけをうまく取得して、カテゴリー別の合計行に代入できないかと考えています。


### 発生している問題・分からないこと
![イメージ説明](https://ddjkaamml8q8x.cloudfront.net/questions/2025-04-23/74a84326-37e7-49c5-b30d-b46257bc37c2.png)

＜困っていること＞
合計する行は固定の行ではないので、「合計」という文字列のある行を取得して、合計するようにしていますが、
①だけならうまくいくのですが、
②の合計を算出する際に、①の下の行からカウントしなければならないのですが（1行目からだと二重計上になるため）、それがうまくいきません。
なぜか、②の行には0が代入されてしまいます。



### 該当のソースコード

```
※試しに以下のコードで一つの列で合計値を出したのですが、問題なく算出され代入されます。

Sub CalculateSpecificSum()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim sumRow As Long
    Dim totalSum As Double
    Dim currentRow As Long
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計値を初期化
    totalSum = 0
    
    ' A列の最初の「合計」行を取得
    sumRow = ws.Columns("A").Find(What:="合計", LookAt:=xlPart, MatchCase:=False).Row

    ' A列の「合計」行までループ
    For currentRow = 6 To sumRow - 1 ' 合計行の直前まで
        ' B列が「合計」の場合のみ処理
        If ws.Cells(currentRow, "B").value Like "*合計*" Then
            ' 12列目（L列）の値を加算
            totalSum = totalSum + ws.Cells(currentRow, 12).value
        End If
    Next currentRow

    ' 合計値をA列の「合計」行のL列に代入
    ws.Cells(sumRow, 12).value = totalSum
    
    MsgBox "指定された合計の計算が完了しました！", vbInformation
End Sub


※以下は、各列ごとに合計値を算出するようにしているはずなのですが、0となり算出されません。

Sub ProcessRevenueSums()
    Dim ws As Worksheet
    Dim sumRow As Long
    Dim totalSum As Double
    Dim currentRow As Long
    Dim colIndex As Variant
    Dim sumColumns As Variant
    
    ' シートを指定
    Set ws = ThisWorkbook.Sheets("収益状況")
    
    ' 合計する列を指定
    sumColumns = Array(12, 13, 14, 18, 19, 20, 21, 24, 25, 26, 27, 28, 29, 30, _
                       34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)

    ' A列の最初の「合計」行を取得
    sumRow = ws.Columns("A").Find(What:="合計", LookAt:=xlPart, MatchCase:=False).Row

    ' 各列を順次処理
    For Each colIndex In sumColumns
        ' 合計値を初期化
        totalSum = 0
        
        ' A列の「合計」行までの範囲をループ
        For currentRow = 6 To sumRow - 1 ' 合計行の直前まで
            ' B列が「合計」の場合のみ処理
            If ws.Cells(currentRow, "B").value Like "*合計*" Then
                ' 該当列の値を加算
                totalSum = totalSum + ws.Cells(currentRow, colIndex).value
            End If
        Next currentRow

        ' 合計値をA列の「合計」行に代入
        ws.Cells(sumRow, colIndex).value = totalSum
    Next colIndex
    
    MsgBox "指定された列に順次合計を代入しました！", vbInformation
End Sub
```

### 試したこと・調べたこと
- [ ] teratailやGoogle等で検索した
- [x] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [ ] その他

##### 上記の詳細・結果
上記に記載のとおりですが、どうしてもうまくいきません。
Excelの関数でしたら実現できると思うのですが、該当する行が変わるので、その都度入力する手間もかかるため、VBAで実現できないかと考えています。
どなたか力を貸していただければ幸いです。
よろしくお願いいたします。

### 補足
特になし

VBAで、複数行あるカテゴリーごとの合計値の算出ができない

AccessのVBAからExcelを開いて指定行を固定する操作をしたいです。

```ACCESS
   Dim ExcelApp As Object
   Dim ExcelBook As Object

   Set ExcelApp = CreateObject("excel.application")
   ExcelApp.Visible = True
   Set ExcelBook = ExcelApp.Workbooks.Open(StrFile)

 ExcelBook.Worksheets("Sheet1").Activate
   range("C2").Select
   ActiveWindow.FreezePanes = True
   ExcelBook.Save
   ExcelBook.Close
   ExcelApp.Quit
   Set ExcelBook = Nothing
   Set ExcelApp = Nothing
```
（関係ないコードは省きました）

「range("C2").Select」の行でエラーが起こっており、要するにRangeがうまくセレクトできないという意味だと思います。
このエラーでググって試行錯誤しましたがどうにもよくわかりませんでした。
実行すると表題のエラーが出るときと出ないときがあり、解決方法が見いだせない状況です。

よろしくお願いします。

実行時エラー"1004"「"Range"メソッドは失敗しました："_Global"オブジェクト」

100行3000列ほどのエクセルデータから
キーワード＝項目 が一致する列を抽出したいです。
![![イメージ説明](92cf181d8e4e9f873c181801b3f283a6.gif)
上記のようなデータ一覧から
   A    B   C
１ 年賀状  氏名  誕生日
２
３
｜
のように、キーワードを選択して
その列に入ってる値をすべて抽出したいです。

また、元のデータ量が変動しても、抽出する
キーワードが変更しても使いやすいように
「元のデータは」セル範囲指定でなく
シート全部もしくは編集中のセル全てを対象としたいです。

キーワードは可能であれば
元のデータとは別シートに記載すると
その別シートのキーワードの列（下）に反映されるようにしたいです。

以前に投稿されていた
【マクロ】検索に一致した条件とその下のセルを抽出
を参考に作成したのですが、
検索設定を行ごとに記述が必要なため、
変動する元のデータに対応しきれませんでした。
マクロを書き換えるのはキーワードが変更になった時だけに
なるような方法で記述するにはどうすれはいいでしょうか？

ご教授のほどよろしくお願い申し上げます。

【マクロ】選択した項目の列をすべて抽出して別シートへ

### 実現したいこと
Haskellで作成したDLL（MyLib.dll）をExcel VBAから呼び出し、ワークシート関数として安定して利用したい。

環境】
Windows 10/11（バージョン明記）

Visual Studio 2022

GHC（Haskellコンパイラ）バージョン

Excel（32/64ビット、バージョン明記）

VBA

### 発生している問題・分からないこと
DLLのビルドは正常に完了し、VBAからDeclare文で呼び出しを試みている

依存DLL不足を疑い、Dependency Walkerで調査したが、「API-MS-」「EXT-MS-」系のみがnot foundで、libHS*やVCランタイム等の不足はなかった

DLLロード時の初期化（DllMain等）は推奨されないため、VBAから明示的に初期化関数を呼び出す方式も試したが、初期化直後にワークシートで関数を使うとExcelが再計算・ブック再オープンを経て正常動作するなど、安定しない。だから、DLLロード時の初期化を進めることにした。
しかし、
「ファイルが見つからない」エラー（エラー48等）が頻発し、依存DLL不足でないことが明らかになった今、解決策が見つからず手詰まり

【確認・試行済み事項】
依存DLL不足なし（Dependency Walkerで確認）

パス、権限、32/64ビット不一致、Excelのキャッシュ等も再確認

DLLの再ビルド・再配置も実施

VBAからの初期化呼び出し方式も試行

### エラーメッセージ
```error
vbaでTestDllLoadWithErrorCheckを実行すると、エラーコード0が出る。
TestTestFuncを実行すると、ファイルが見つかりません。（エラー 48）というエラーが出る。
```

### 該当のソースコード

```MyLib.hs
{-# LANGUAGE ForeignFunctionInterface #-}
module MyLib where

import Foreign
import Foreign.C.Types
import Foreign.C.String (CWString, peekCWString)
import qualified Data.Map.Strict as Map
import Data.Char (isSpace, ord)
import System.IO (hPutStrLn, stderr)

-- Mapの値をEither String Int型にする
myDict :: Map.Map Int (Either String Int)
myDict = Map.fromList [
 (32, Right 0),
 (33, Right 1),
 (38, Right 25),
以下続く
(12291, Right 1),
 (65293, Right 1)
  ]

-- C言語から呼び出せるようにエクスポート
{-# LANGUAGE ForeignFunctionInterface #-}

-- 文字列のn番目（1始まり）のUnicode値を返す（空白は除去）
foreign export ccall real_len :: CWString -> CInt -> CInt -> IO CInt

real_len :: CWString -> CInt -> CInt -> IO CInt
real_len cws elem1 elem2 = do
  hPutStrLn stderr "real_len: 関数が呼ばれました"
  str <- peekCWString cws  -- ここでUTF-16（BSTR）を正しくHaskellのStringに変換
  hPutStrLn stderr $ "real_len: 入力文字列=" ++ str
  let strNoSpaces = filter (not . isSpace) str
      idx = fromIntegral elem2 - 1  -- elem2は1始まり
  if null strNoSpaces || idx < 0 || idx >= length strNoSpaces
    then do
      hPutStrLn stderr "real_len: 範囲外または空文字列"
      return (-1)
    else do
      let ch = strNoSpaces !! idx
      hPutStrLn stderr $ "real_len: 抽出文字=" ++ [ch]
      return (fromIntegral . ord $ ch)
```

```wrapper.c
#include <windows.h>
#include <oleauto.h>  // BSTR用
#include <HsFFI.h>
#include <wchar.h>
#include <stdio.h>    // printf用

#ifdef __cplusplus
extern "C" {
#endif

    // Haskell関数の宣言
    extern HsInt32 real_len(const wchar_t* s, HsInt32 elem1, HsInt32 elem2);

    // DLLロード時にHaskellランタイムを初期化
    BOOL WINAPI DllMain(HINSTANCE hinstDLL, DWORD fdwReason, LPVOID lpvReserved) {
        static int initialized = 0;
        if (fdwReason == DLL_PROCESS_ATTACH && initialized == 0) {
            int argc = 0;
            char** argv = NULL;
            hs_init(&argc, &argv);
            initialized = 1;
        }
        return TRUE;
    }

    // VBAから呼び出すラッパー
    __declspec(dllexport) HsInt32 __stdcall real_len_wrapper(BSTR s, HsInt32 elem1, HsInt32 elem2) {
        MessageBoxW(NULL, L"real_len_wrapper called", L"Debug", MB_OK);  // ←ここで呼ぶ
        OutputDebugStringA("real_len_wrapper: 関数が呼ばれました\n");
        if (s == NULL) {
            OutputDebugStringA("real_len_wrapper: BSTRがNULLです\n");
            return -1;
        }
        // BSTRはwchar_t*として使える。Haskell側もCWStringでOK
        return real_len((const wchar_t*)s, elem1, elem2);
    }

    // ★テスト用の引数なし関数
    __declspec(dllexport) int __stdcall test_func() {
        MessageBoxW(NULL, L"test_func called", L"Debug", MB_OK);
        OutputDebugStringA("test_func: called\n");
        return 42;
    }

#ifdef __cplusplus
}
#endif

```

```StartEnd.c
#include <HsFFI.h>
#include <stddef.h>  // ← これを追加

// DllMainは絶対に定義しないでください

// Haskellランタイムの手動初期化関数
void HsStart() {
    int argc = 1;
    char* argv[] = { "ghcDll", NULL };
    char** args = argv;
    hs_init(&argc, &args);
}

// Haskellランタイムの手動終了関数
void HsEnd() {
    hs_exit();
}

```

```vba
' 64ビットExcel専用のDLL/API宣言
Declare PtrSafe Function real_Len_wrapper Lib "D:\visual_studio_2022\Git_repos_folderpath\MyLib.dll" Alias "real_len_wrapper" (ByVal s As String, ByVal elem1 As Long, ByVal elem2 As Long) As Long
Declare PtrSafe Function test_func Lib "D:\visual_studio_2022\Git_repos_folderpath\MyLib.dll" () As Long
Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
Declare PtrSafe Function GetLastError Lib "kernel32" () As Long

' DLLロードとエラー取得のテスト
Sub TestDllLoadWithErrorCheck()
    Dim hLib As LongPtr
    Dim errCode As Long
    Dim dllPath As String
    dllPath = "D:\visual_studio_2022\Git_repos_folderpath\MyLib.dll"

    If Dir(dllPath) = "" Then
        MsgBox "DLLが見つかりません: " & dllPath, vbCritical
        Exit Sub
    End If

    hLib = LoadLibrary(dllPath)
    If hLib = 0 Then
        errCode = GetLastError()
        MsgBox "DLLのロード失敗 - エラーコード: " & errCode, vbCritical
    Else
        Debug.Print "DLLロード成功: " & hLib
        FreeLibrary hLib
    End If
End Sub

' セルの値をDLL関数に渡して長さを取得する関数
Function Real_Len1(rng As Range, elem1 As Long, elem2 As Long) As Long
    Dim s As String
    Dim errCode As Long

    On Error Resume Next
    s = rng.Value

    If Len(s) = 0 Then
        Real_Len1 = -1
        Exit Function
    End If

    ' DLL関数を直接呼び出す
    Real_Len1 = real_Len_wrapper(s, elem1, elem2)
    errCode = GetLastError()
    If errCode <> 0 Then
        Debug.Print "real_len_wrapper呼び出しエラー: " & errCode
    End If
End Function

' DLLのtest_funcを呼び出して動作確認
Sub TestTestFunc()
    Dim ret As Long
    ret = test_func()
    MsgBox "test_funcの戻り値: " & ret
End Sub


```
LIBRARY MyLib
EXPORTS
    real_len_wrapper


### 試したこと・調べたこと
- [ ] teratailやGoogle等で検索した
- [ ] ソースコードを自分なりに変更した
- [ ] 知人に聞いた
- [x] その他

##### 上記の詳細・結果
AIに聞いてコードを書いた。

### 補足
特になし

Haskellで作成したDLLをExcel VBAから安定して利用できない（依存DLL不足ではない）

VBAで書きたいです。

特定の範囲(出来れば図のような範囲、難しい場合はシート全体からでもOK)に
オレンジがあればB1セルに[A]、オレンジがない場合はB1セルに[B]と記載したい場合
どの様にコードを書いたらいいでしょうか。

こんな感じかな、と書いてみたのですが、見当違いなようで動きません。

どなたかアドバイスお願いします。

![イメージ説明](e5f26fb0f03a8b005a5862cdf6a24d72.png)

```VBA
Sub Test()
    
    Dim Flag
    
	Select Case True
		Case Range("I8:T17").Interior.ColorIndex = RGB(0、166、93)　　　　　'緑
		Case Range("I8:T17").Interior.ColorIndex = RGB(237、28、36)　　     '赤
		Case Range("I8:T17").Interior.ColorIndex = RGB(255, 255, 255)　　   '白　　
		Case Else
			Flag = False
	End Select
	
	If Flag = False Then
		Range("B2") = "〇"
	Else
		Range("B2") = "×"
	End If
		

End Sub
```