Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


53150 / 76732 ←次へ | 前へ→

【28401】Re:メモリ使用量
発言  EXCEL_VBA中の下  - 05/9/5(月) 16:37 -

引用なし
パスワード
   ▼ちくたくさん、小僧 さん:
よろしくお願いします。

>http://www.tsware.jp/labo/labo_19.htm
 読みましたがよくわかりませんでした・・。すみません。

以下マクロを記述いたします。
質問「 【28269】とある条件のレコードだけ合計が必要な場合 」からの延長です。
細かい部分はこちらも参考してください。

素人なのでいろいろ突っ込む部分があるかと思います。
今回の質問外でも、
 「ここは、こうした方が見易い」
 「この方が効率的」
 「この方が美しい」
などありましたら、ご指摘お願いします。

【module1】
Sub MAKE_UA()
  Dim rs As Object
  Dim mysql As String
  Dim IN_DATA_SHEET_NM As String
  Dim OT_Folder_NM As String
  Dim OT_File_NM As String
  
  Application.Cursor = xlWait
  Application.StatusBar = "しばらくお待ちください"
  Application.ScreenUpdating = False
  Sheets("MAKE_DATA").Activate
  ActiveSheet.Range("A1:IV65535").Select
  Selection.Clear
  Sheets("WORK").Activate
  ActiveSheet.Range("A1:IV65535").Select
  Selection.Clear
  Sheets("設定").Activate
  IN_DATA_SHEET_NM = ActiveSheet.Range("C2")
  OT_Folder_NM = ActiveSheet.Range("C3")
  If Right(OT_Folder_NM, 1) <> "\" Then
    OT_Folder_NM = OT_Folder_NM & "\"
  End If
  OT_File_NM = ActiveSheet.Range("C4")
  
  If Open_ADO_Excel(ThisWorkbook.FullName) = 0 Then
    mysql = "Select [FLG],[YYYY],[MM],[CODE_A],[CODE_B],[CODE_C],[CODE_D],[KIN-SEI] " & _
        " From [" & IN_DATA_SHEET_NM & "$] " & _
        " Where [CODE_D] <> '03' " & _
        "  AND [CODE_D] <> '04' " & _
        "Union All " & _
        "Select [FLG],[YYYY],[MM],[CODE_A],[CODE_B],[CODE_C],[CODE_D],Sum([KIN-SEI]) " & _
        " From [" & IN_DATA_SHEET_NM & "$] " & _
        " Where [CODE_D] = '03' " & _
        "  Or [CODE_D] = '04' " & _
        " Group By [FLG],[YYYY],[MM],[CODE_A],[CODE_B],[CODE_C],[CODE_D] " & _
        " Order By [YYYY],[MM],[CODE_A],[CODE_B],[CODE_C],[CODE_D] "
    If Get_Exec_SQL(mysql, rs) = 0 Then
      With Worksheets("WORK")
        .Cells.ClearContents
        .Range("A2").CopyFromRecordset rs
        .Range("A1:H1").Value = Array("UA", "YYYY", "MM", "CODE_A", "CODE_B", "CODE_C", "CODE_D", "KIN-SEI")
      End With
      Call rs_Close(rs)
      Call Close_ADO
    Else
      Call Close_ADO
      GoTo ERR_RTN
    End If
  Else
      GoTo ERR_RTN
  End If
  Sheets("WORK").Activate
  ActiveSheet.Range("B2:H2").Select
  ActiveSheet.Range(Selection, Selection.End(xlDown)).Select
  Selection.Copy
  Sheets("MAKE_DATA").Activate
  ActiveSheet.Range("A1").Select
  ActiveSheet.Paste
  ActiveSheet.Range("A1").End(xlDown).Offset(1, 0).Select
'ファイル出力
  Application.DisplayAlerts = False
  Sheets("MAKE_DATA").Activate
  Sheets("MAKE_DATA").Copy
  ActiveWorkbook.SaveAs Filename:=OT_Folder_NM & OT_File_NM & ".CSV", FileFormat:=xlCSV, CreateBackup:=False
  ActiveWindow.Close
  Application.DisplayAlerts = True
  Sheets("設定").Activate
  Application.ScreenUpdating = True
  Application.StatusBar = False
  Application.Cursor = xlDefault
  MsgBox OT_Folder_NM & OT_File_NM & ".CSVを作成しました。"
  
  Exit Sub
  
ERR_RTN:
  Application.DisplayAlerts = False
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
  Application.StatusBar = False
  Application.Cursor = xlDefault
  MsgBox "作成に失敗しました。"
End Sub
'======================================================

【module2】

Public cn As Object
'======================================================
Function Open_ADO_Excel(Book_Fullname As String) As Long
  On Error Resume Next
  link_opt = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
       "Data Source=" & Book_Fullname & ";" & _
       "Extended Properties=Excel 8.0;"
  Set cn = CreateObject("ADODB.Connection")
  cn.Open link_opt
  Open_ADO_Excel = Err.Number
  On Error GoTo 0

End Function
'======================================================
Sub Close_ADO()
  On Error Resume Next
  Set cn = Nothing
  cn.Close
  On Error GoTo 0
End Sub
'======================================================
Function Get_Exec_SQL(SQL_Str, rs As Object) As Long
  On Error Resume Next
  Set rs = cn.Execute(SQL_Str)
  Get_Exec_SQL = Err.Number
  If Err.Number <> 0 Then
    MsgBox Err.Number & "::" & Err.Description
    End If
  On Error GoTo 0
End Function
'======================================================
Sub rs_Close(rs As Object)
  On Error Resume Next
  Set rs = Nothing
  rs.Close
  On Error GoTo 0
End Sub
0 hits

【28395】メモリ使用量 EXCEL_VBA中の下 05/9/5(月) 14:34 質問
【28396】Re:メモリ使用量 ちくたく 05/9/5(月) 14:53 発言
【28400】Re:メモリ使用量 小僧 05/9/5(月) 16:16 発言
【28401】Re:メモリ使用量 EXCEL_VBA中の下 05/9/5(月) 16:37 発言
【28403】Re:メモリ使用量 小僧 05/9/5(月) 17:39 発言
【28415】Re:メモリ使用量 ichinose 05/9/6(火) 7:59 発言
【28427】Re:メモリ使用量 EXCEL_VBA中の下 05/9/6(火) 14:41 発言
【28447】Re:メモリ使用量 実験1 ichinose 05/9/6(火) 20:28 発言
【28448】Re:メモリ使用量 実験2 ichinose 05/9/6(火) 20:49 発言
【28451】Re:メモリ使用量 補足 ichinose 05/9/7(水) 6:56 発言
【28452】Re:メモリ使用量 補足2 ichinose 05/9/7(水) 8:06 発言
【28453】Re:メモリ使用量 補足2 ちくたく 05/9/7(水) 8:47 回答
【28488】Re:メモリ使用量 補足2 よろずや 05/9/7(水) 22:33 発言
【28499】Re:メモリ使用量 補足2 ichinose 05/9/8(木) 8:32 発言
【28537】Re:メモリ使用量 補足2 よろずや 05/9/8(木) 19:29 発言
【28541】Re:メモリ使用量 補足2 小僧 05/9/8(木) 22:18 質問
【28542】Re:メモリ使用量 補足2 よろずや 05/9/8(木) 22:49 発言
【28544】Re:メモリ使用量 補足2 小僧 05/9/9(金) 0:12 質問
【28545】Re:メモリ使用量 補足2 ichinose 05/9/9(金) 1:36 発言
【28555】Re:メモリ使用量 補足2 小僧 05/9/9(金) 10:39 質問
【28570】Re:メモリ使用量 補足2 よろずや 05/9/9(金) 12:59 発言
【28597】Re:メモリ使用量 補足2 ichinose 05/9/9(金) 17:20 発言
【28598】Re:メモリ使用量 補足2 小僧 05/9/9(金) 17:47 お礼
【28402】Re:メモリ使用量 ちくたく 05/9/5(月) 16:51 発言

53150 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free