2008年09月27日

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

'「顧客番号」の列を切り取って、第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」を極める」早坂 清志 毎日コミュニケーションズ

ラベル:EXCEL VBA
posted by alice-room at 00:21| Comment(0) | TrackBack(0) | 【備忘録B】 | 更新情報をチェックする
この記事へのコメント
コメントを書く
コチラをクリックしてください

この記事へのトラックバック