【メモ】・・・・赤字部分参照
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
'「顧客番号」の列を切り取って、第1列に挿入
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」を極める」早坂 清志 毎日コミュニケーションズ