excel用VBAサンプルソース 20080926

【メモ】・・・・赤字部分参照　
EXCELからACCESSのデータを呼び出し、検索キーに該当するデータを取り出す時、変数が利用できずに大変苦労した！

エラー処理

アラートの停止
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Option Explicit

Sub 住所データ()

　Sheets("入力用").Unprotect
　Dim 検索番号 As String
　検索番号 = Range("c30").Value

　Sheets("入力用").Range("31:32").Delete

'宛名ラベル.mdb（アクセス）から、顧客番号を検索キーとして住所データを抽出

　With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
　　　"ODBC;DSN=MS Access Database;DBQ=～～～\02.顧客宛名ラベル作成\宛名ラベル作成.mdb;DefaultDir=～～～\02.顧客宛名ラベル作成;DriverId=25;F" _
　　　), rray("IL=MSAccess;MaxBufferSize=2048;PageTimeout=5;")), Destination:=Range("C31"))
　　　.CommandText = Array( _
　　　　"SELECT 宛名用住所DB準備.顧客番号, 宛名用住所DB準備.郵便〒, 宛名用住所DB準備.住所, 宛名用住所DB準備.氏名" & Chr(13) & "" & Chr(10) & "FROM 宛名用住所DB準備 宛名用住所DB準備" _
　　　　& Chr(13) & "" & Chr(10) & "WHERE (宛名用住所DB準備.顧客番号="& 検索番号 & ")")
　　　　.Name = "MS Access Database からのクエリ_1"
　　　　.FieldNames = True
　　　　.RowNumbers = False
　　　　.FillAdjacentFormulas = False
　　　　.PreserveFormatting = True
　　　　.RefreshOnFileOpen = False
　　　　.BackgroundQuery = True
　　　　.RefreshStyle = xlInsertDeleteCells
　　　　.SavePassword = False
　　　　.SaveData = True
　　　　.AdjustColumnWidth = False
　　　　.RefreshPeriod = 0
　　　　.PreserveColumnInfo = True
　　　　.Refresh BackgroundQuery:=False
　　End With

　　Range("c30:f32").Font.ColorIndex = 2
　　Sheets("入力用").Protect

'初期契約手数料シート上へ転記
　　Sheets("初期契約手数料").Range("c5").Value = Sheets("入力用").Range("d32").Value
　　Sheets("初期契約手数料").Range("c6").Value = Sheets("入力用").Range("e32").Value
　　Sheets("初期契約手数料").Range("c8").Value = Sheets("入力用").Range("d30").Value
　　Sheets("初期契約手数料").Range("f9").Value = Sheets("入力用").Range("e30").Value

'お知らせシート上へ転記
　　Sheets("お知らせ").Range("c5").Value = Sheets("入力用").Range("d32").Value
　　Sheets("お知らせ").Range("c6").Value = Sheets("入力用").Range("e32").Value
　　Sheets("お知らせ").Range("c8").Value = Sheets("入力用").Range("d30").Value
　　Sheets("お知らせ").Range("f9").Value = Sheets("入力用").Range("e30").Value

End Sub

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Sub kokyaku_sort()
'マクロ記録日 : 2008/9/25

'事前準備の確認を表示
　　Dim 事前準備 As String

　　事前準備 = MsgBox("DWHからの　xxx01.csv　を更新しないと、" & vbCr & "『送付先更新日』　が更新されません。" _
　　& vbCr & vbCr & "処理を継続しますか？" _
　　, vbDefaultButton1 + vbOKCancel, "事前準備の確認")


'処理作業を継続させるか否かの分岐処理
　　If 事前準備 = vbCancel Then
　　　　　　MsgBox ("処理を中止しました。")
　　　　　　Exit Sub
　　End If

'----------------------------------------------------------------------------------
' cc対応 Macro ・・・CC対応準備シートのA～C列をE～Gにコピーし、顧客番号・完了日の順に降順で並び替え

　　Sheets("CC対応準備").Select
　　Range("A6:C6000").Select　　
　　Selection.Copy
　　Range("E6").Select
　　Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
　　　　:=False, Transpose:=False

　　Range("E6:G6000").Select
　　Selection.Sort Key1:=Range("E7"), Order1:=xlDescending, Key2:=Range("G7") _
　　　　, Order2:=xlDescending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
　　　　False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin, DataOption1:= _
　　　　xlSortTextAsNumbers, DataOption2:=xlSortNormal
'----------------------------------------------------------------------------------
' 在庫件数 Macro
'変数の宣言
　　Dim 在庫件数 As Integer
　　Dim 処理済件数 As Integer
　　Dim 再送付検印者 As String
　　Dim 破棄検印者 As String
　　Dim 返戻理由 As String
　　Dim 理由1 As Integer
　　Dim 理由2 As Integer
　　Dim 理由3 As Integer
　　Dim 理由4 As Integer
　　Dim 理由5 As Integer
　　Dim 理由6 As Integer
　　Dim i As Integer
　　Dim 対象件数 As Integer

　　Sheets("管理シート").Select

'『対象件数＝在庫件数+処理済件数』
　　対象件数 = 9999 - WorksheetFunction.CountIf(Sheets("管理シート").Range("b1:b10000"), "")


'在庫と処理済み件数の計算
　　For i = 3 To 対象件数 + 2
　　再送付検印者 = Sheets("管理シート").Cells(i, 17).Value
　　破棄検印者 = Sheets("管理シート").Cells(i, 20).Value

　　　If 再送付検印者 = "" Then
　　　　　If 破棄検印者 = "" Then
　　　　　　在庫件数 = 在庫件数 + 1
　'返戻理由の内訳を計算
　　　　　　返戻理由 = Left(Cells(i, 4), 3)
　　　　　　　　Select Case 返戻理由
　　　　　　　　　　Case "転居の"
　　　　　　　　　　　　理由1 = 理由1 + 1
　　　　　　　　　　Case "転居先"
　　　　　　　　　　　　理由2 = 理由2 + 1
　　　　　　　　　　Case "あて所"
　　　　　　　　　　　　　理由3 = 理由3 + 1
　　　　　　　　　　Case "転送不"
　　　　　　　　　　　　　理由4 = 理由4 + 1
　　　　　　　　　　Case "保管期"
　　　　　　　　　　　　　理由5 = 理由5 + 1
　　　　　　　　　　Case Else
　　　　　　　　　　　　　理由6 = 理由6 + 1
　　　　　　　　　　End Select
　　　　　　　　Else
　　　　　　　　　　処理済件数 = 処理済件数 + 1
　　　　　　End If
　　　　Else
　　　　　　処理済件数 = 処理済件数 + 1
　　　End If
　　Next

　　Sheets("在庫管理").Range("c3").Value = 対象件数
　　Sheets("在庫管理").Range("c9").Value = 在庫件数
　　Sheets("在庫管理").Range("c10").Value = 処理済件数

　　Sheets("在庫管理").Range("G11").Value = 理由1
　　Sheets("在庫管理").Range("G12").Value = 理由2
　　Sheets("在庫管理").Range("G13").Value = 理由3
　　Sheets("在庫管理").Range("G14").Value = 理由4
　　Sheets("在庫管理").Range("G15").Value = 理由5
　　Sheets("在庫管理").Range("G16").Value = 理由6
'----------------------------------------------------------------------------------
' 送付先更新日 Macro
'変数の宣言
　　Dim 送付先更新日 As String
　　Dim 顧客番号 As String
　　Dim j As Integer

'「送付先更新日作業用」と名付けた新規シートを追加&アラートの停止＆復活
　　Application.DisplayAlerts = False
　　Sheets("送付先更新日作業用").Delete
　　Sheets.Add.Name = "送付先更新日作業用"
　　Application.DisplayAlerts = True

'「送付先更新日作業用」上記シート上にcsvファイルのデータを取り込み
　　Cells.Select
　　With ActiveSheet.QueryTables.Add(Connection:= _
　　　　"TEXT;～～～\02.顧客宛名ラベル作成\xxx01.csv", Destination:=Range("A1"))
　　　　.Name = "xxx01"
　　　　.FieldNames = True
　　　　.RowNumbers = False
　　　　.FillAdjacentFormulas = False
　　　　.PreserveFormatting = True
　　　　.RefreshOnFileOpen = False
　　　　.RefreshStyle = xlInsertDeleteCells
　　　　.SavePassword = False
　　　　.SaveData = True
　　　　.AdjustColumnWidth = True
　　　　.RefreshPeriod = 0
　　　　.TextFilePromptOnRefresh = False
　　　　.TextFilePlatform = 932
　　　　.TextFileStartRow = 1
　　　　.TextFileParseType = xlDelimited
　　　　.TextFileTextQualifier = xlTextQualifierDoubleQuote
　　　　.TextFileConsecutiveDelimiter = False
　　　　.TextFileTabDelimiter = True
　　　　.TextFileSemicolonDelimiter = False
　　　　.TextFileCommaDelimiter = True
　　　　.TextFileSpaceDelimiter = False
　　　　.TextFileColumnDataTypes = Array(1, 1, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1)
　　　　.TextFileTrailingMinusNumbers = True
　　　　.Refresh BackgroundQuery:=False
　　End With

'「顧客番号」の列を切り取って、第１列に挿入
　　Columns("C:C").Select
　　Selection.Cut
　　Columns("A:A").Select
　　Selection.Insert Shift:=xlToRight
　　On Error Resume Next

'処理をする件数は、実際に当社受入日が入力されている件数（＝対象件数)を加えたもの
　　For j = 3 To 対象件数 + 2
　　　　送付先更新日 = ""
　　　　顧客番号 = WorksheetFunction.Trim(Sheets("管理シート").Cells(j, 6).Value)

　　　　送付先更新日 = WorksheetFunction.VLookup(顧客番号, Sheets("送付先更新日作業用").Range("a2:c3000"), 3, False)

　　　　Sheets("管理シート").Cells(j, 10).Value = Mid(送付先更新日, 1, 4) & "/" & Mid(送付先更新日, 5, 2) & "/" & Mid(送付先更新日, 7, 2)
　　Next j

　　On Error GoTo 0

'「送付先更新日作業用」シートは非表示にしておく
　　Sheets("送付先更新日作業用").Visible = False

'作業完了メッセージ表示
　　MsgBox ("更新作業完了しました。")
End Sub

★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★
Sub お知らせ作成_入力用() ・・・・・20080919　最新版

'変数を宣言。手数料金額（月間基本）を　m　とする
　　Dim m As String
　　Dim 行 As String
　　Dim 列 As String　　
　　Dim 振替日FLG As String
　　Dim 振替日 As String
　　Dim 振替日区分 As String

　　Dim 請求件数As Integer
　　Dim 請求金額 As Integer
　　Dim 振替不能件数 As Integer
　　Dim 振替不能金額 As Integer
　　Dim 振替済件数 As Integer
　　Dim 振替済金額 As Integer
　　Dim 資金不足件数 As Integer
　　Dim 資金不足金額 As Integer
　　Dim 取引なし件数 As Integer
　　Dim 取引なし金額 As Integer
　　Dim 預金者都合停止件数 As Integer
　　Dim 預金者都合停止金額 As Integer
　　Dim 依頼契約なし件数 As Integer
　　Dim 依頼契約なし金額 As Integer
　　Dim 委託者都合停止件数 As Integer
　　Dim 委託者都合停止金額 As Integer
　　Dim その他件数 As Integer
　　Dim その他金額 As Integer

' シート非表示
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Visible = False
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Visible = False

' 「入力用」シートで指定された条件に合う振替日を探す
　　振替日区分 = Sheets("入力用").Cells(10, 5).Value
　　行 = WorksheetFunction.Match(Sheets("入力用").Range("d10"), Sheets("口座振替").Range("a1:a226"), 0)
　　列 = WorksheetFunction.Match(Sheets("入力用").Range("c10"), Sheets("口座振替").Range("a3:ca3"), 0)

　　Select Case 振替日区分
　　　　Case "a"
　　　　　　If 振替日区分 = Sheets("口座振替").Cells(5, 列).Value Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("振替日区分が間違っています。確認して下さい。")
　　　　　　　　　　GoTo 200
　　　　　　End If
　　　　Case "b"
　　　　　　列 = 列 + 1
　　　　　　If 振替日区分 = Sheets("口座振替").Cells(5, 列).Value Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("振替日区分が間違っています。確認して下さい。")
　　　　　　　　　　GoTo 200
　　　　　　End If
　　　　Case "c"
　　　　　　列 = 列 + 2
　　　　　　If 振替日区分 = Sheets("口座振替").Cells(5, 列).Value Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("振替日区分が間違っています。確認して下さい。")
　　　　　　　　　　GoTo 200
　　　　　　End If

　　　　Case "d"
　　　　　　列 = 列 + 3
　　　　　　If 振替日区分 = Sheets("口座振替").Cells(5, 列).Value Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("振替日区分が間違っています。確認して下さい。")
　　　　　　　　　　GoTo 200
　　　　　End If

　　　　Case "e"
　　　　　　列 = 列 + 4
　　　　　　If 振替日区分 = Sheets("口座振替").Cells(5, 列).Value Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("振替日区分が間違っています。確認して下さい。")
　　　　　　　　　　GoTo 200
　　　　　　End If

　　　　Case "f"
　　　　　　列 = 列 + 5
　　　　　　If 振替日区分 = Sheets("口座振替").Cells(5, 列).Value Then
　　　　　　　　Else
　　　　　　　　　　MsgBox ("振替日区分が間違っています。確認して下さい。")
　　　　　　　　　　GoTo 200
　　　　End If
　　End Select

　　振替日FLG = Right(Sheets("口座振替").Cells(行, 列).Value, 2)

'口座振替シート上から、該当する数値をpickup
　　振替日 = Sheets("口座振替").Cells(行, 列).Value
　　請求件数 = Sheets("口座振替").Cells(行 + 1, 列).Value
　　請求金額 = Sheets("口座振替").Cells(行 + 2, 列).Value
　　振替不能件数 = Sheets("口座振替").Cells(行 + 3, 列).Value
　　振替不能金額 = Sheets("口座振替").Cells(行 + 4, 列).Value
　　振替済件数 = Sheets("口座振替").Cells(行 + 5, 列).Value
　　振替済金額 = Sheets("口座振替").Cells(行 + 6, 列).Value
　　資金不足件数 = Sheets("口座振替").Cells(行 + 7, 列).Value
　　資金不足金額 = Sheets("口座振替").Cells(行 + 8, 列).Value
　　取引なし件数 = Sheets("口座振替").Cells(行 + 9, 列).Value
　　取引なし金額 = Sheets("口座振替").Cells(行 + 10, 列).Value
　　預金者都合停止件数 = Sheets("口座振替").Cells(行 + 11, 列).Value
　　預金者都合停止金額 = Sheets("口座振替").Cells(行 + 12, 列).Value
　　依頼契約なし件数 = Sheets("口座振替").Cells(行 + 13, 列).Value
　　依頼契約なし金額 = Sheets("口座振替").Cells(行 + 14, 列).Value
　　委託者都合停止件数 = Sheets("口座振替").Cells(行 + 15, 列).Value
　　委託者都合停止金額 = Sheets("口座振替").Cells(行 + 16, 列).Value
　　その他件数 = Sheets("口座振替").Cells(行 + 17, 列).Value
　　その他金額 = Sheets("口座振替").Cells(行 + 18, 列).Value

'口座振替結果のお知らせ(月間手数料無し)シートへ該当数値を転記
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("o26").Value = 振替日
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("m29").Value = 請求件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ac29").Value = 請求金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("m30").Value = 振替不能件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ac30").Value = 振替不能金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("m31").Value = 振替済件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ac31").Value = 振替済金額

　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("q36").Value = 資金不足件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ab36").Value = 資金不足金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("q37").Value = 取引なし件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ab37").Value = 取引なし金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("q38").Value = 預金者都合停止件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ab38").Value = 預金者都合停止金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("q39").Value = 依頼契約なし件数

　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ab39").Value = 依頼契約なし金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("q40").Value = 委託者都合停止件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ab40").Value = 委託者都合停止金額
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("q41").Value = その他件数
　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Range("ab41").Value = その他金額

'口座振替結果のお知らせ(月間手数料有り)シートへ該当数値を転記
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("o24").Value = 振替日

　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("m27").Value = 請求件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ac27").Value = 請求金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("m28").Value = 振替不能件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ac28").Value = 振替不能金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("m29").Value = 振替済件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ac29").Value = 振替済金額

　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("q34").Value = 資金不足件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ab34").Value = 資金不足金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("q35").Value = 取引なし件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ab35").Value = 取引なし金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("q36").Value = 預金者都合停止件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ab36").Value = 預金者都合停止金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("q37").Value = 依頼契約なし件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ab37").Value = 依頼契約なし金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("q38").Value = 委託者都合停止件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ab38").Value = 委託者都合停止金額
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("q39").Value = その他件数
　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Range("ab39").Value = その他金額

'削除内容確認アラートの停止＆復活
　　Application.DisplayAlerts = False
　　Sheets("口振委託者一覧").Delete
　　Application.DisplayAlerts = True

　　Workbooks.Open Filename:=("～～～\26.口座振替\01.委託者一覧表\委託者一覧表.xls")
　　Sheets("口振委託者一覧").Select
　　Sheets("口振委託者一覧").Copy Before:=Workbooks("口座振替.xls").Sheets(1)
　　Workbooks("委託者一覧表.xls").Close SaveChanges:=False

'手数料金額（月間基本）が「無料」か否かの振り分け
　　m = WorksheetFunction.VLookup(Sheets("入力用").Cells(10, 3).Value, Sheets("口振委託者一覧").Range("a4:ac100"), 7, False)

　　If m = "無料" Then
　　　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Visible = True
　　　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Activate

'振替日FLGが16日以降か否かで判断
　　　ElseIf 振替日FLG > "15" Then
　　　　　　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Visible = True
　　　　　　　Sheets("口座振替結果のお知らせ(月間手数料有り)").Activate
　　　　　　Else
　　　　　　　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Visible = True
　　　　　　　　Sheets("口座振替結果のお知らせ(月間手数料無し)").Activate
　　End If

200
End Sub
★★★★★★★★★★★★★★★★★★★★★★★★★★★★★★

ブログ内関連記事
アクセスVBAでの作業メモ（20080515）
「Excelの極意(6)「VBA」を極める」早坂 清志 毎日コミュニケーションズ