| |
▼ちくたくさん、小僧 さん：
よろしくお願いします。
>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
|
|
EXCEL_VBA中の下
- 05/9/5(月) 16:37 -
