Excel VBAに効く Vitamin E
Excel振込のソースコードの一部を公開(全銀データ項目の関連付け)
読者のご要望にお応えし、Excel振込の全銀データ項目の関連付け部分のコードを公開します。一部APIを使用していますが、ほとんどExcelの機能を使っています。高度なことはやっていませんが参考にしてください。
Option Explicit

'フルパス名からファイル名を取得
Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
'ファイルが存在するか
Private Declare Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
'pszPath[in]:ファイル名
'Return :存在すれば 1、存在しなければ 0 がかえる。
'(注)SDKでは \\ serverのように Universal Naming Convention (UNC)を指定すると 0 がかえると記述があるが、正常に動作する。

Const 選択項目Max = 17
Const c全銀データ項目Max = 8
Const cPrgName = "関連付けサンプル"

Dim 選択項目(1, 1 To 選択項目Max) As String
Dim preText1 As String

Private Sub CommandButton1_Click()
'読込ファイル参照ボタンクリック時
 Dim DefDir As String
 Dim fileSaveName
 Dim wTextBox As String

 'ファイル読込ダイアログの初期フォルダ表示のため
 'ドライブとフォルダを設定
 wTextBox = Me!TextBox1.Value
 If Trim$(wTextBox) = "" Then
  DefDir = ThisWorkbook.Path
 Else
  DefDir = LsGetPath(wTextBox, "")
 End If
 On Error Resume Next
 ChDrive DefDir
 ChDir DefDir
 If Err Then
  ChDrive ThisWorkbook.Path
  ChDir ThisWorkbook.Path
  Err.Clear
 End If
 On Error GoTo 0

 'ファイル読込ダイアログ
 fileSaveName = Application.GetOpenFileName( _
  FileFilter:="Excelファイル(*.xls),*.xls,CSVファイル(*.CSV),*.CSV,テキストファイル(*.TXT),*.TXT,全てのファイル(*.*),*.*", _
  FilterIndex:=1, Title:="変換するExcelまたはCSVファイルを選択して下さい")
 If fileSaveName <> False Then
  Me!TextBox1.Value = fileSaveName
  XlsSheetToCombo fileSaveName
  Me!TextBox2.Value = 0
  Me!TextBox3.Value = 1
  Me!TextBox4.Value = 0
  ScrollBar1MaxSet
 End If
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
'シート名コンボボックス、ダブルクリック時
 Dim i As Integer, wList As String, k As String

 i = Me!ListBox1.ListIndex
 wList = Trim$(Me!ListBox1.List(i, 0))
 With Me!ScrollBar1
  If Len(Trim$(wList)) > c全銀データ項目Max And Mid$(wList, c全銀データ項目Max, 2) = " [" And _
   Right$(wList, 1) = "]" Then
   Me!ListBox1.List(i, 0) = Left$(wList, c全銀データ項目Max)
  ElseIf .Min <= .Value And .Value <= .Max Then
   If Val(Me!TextBox2.Value) > 0 Then k = ActiveSheet.Cells(Val(Me!TextBox2.Value), .Value)
   Me!ListBox1.List(i, 0) = Left$(wList & String$(c全銀データ項目Max, " "), c全銀データ項目Max) & _
    "[" & ColConv(str$(.Value)) & " " & k & "]"
  End If
 End With
End Sub

Private Function ColConv(ByVal v As String) As String
'カラム取り出し
 Dim c As String, i As Integer

 v = Trim$(v)
 If IsNumeric(v) Then
  c = ActiveSheet.Cells(1, Val(v)).Address()
  i = InStr(2, c, "$")
  ColConv = Mid(c, 2, i - 2)
 Else
  c = ActiveSheet.Range(v & "1").Address(ReferenceStyle:=xlR1C1)
  i = InStr(2, c, "C")
  ColConv = Mid$(c, i + 1)
 End If
End Function

Private Sub ComboBox1_Click()
'シート名コンボボックス、クリック時
 On Error Resume Next
 ActiveSheet.Cells(1, 1).Select
 ActiveWorkbook.Worksheets(Me!ComboBox1.Text).Activate
 ActiveSheet.Cells(1, 1).Select
 ScrollBar1MaxSet
End Sub

Private Sub ListBox1Set()
'全銀データ項目の関連付けリストボックス設定
 Dim i As Integer, j As Integer

 With Me!ListBox1
.  Clear
  For i = 1 To 選択項目Max
   If 選択項目(1, i) = "" Then
.    AddItem
.    List(j, 0) = 選択項目(0, i)
.    List(j, 1) = str$(i)
    j = j + 1
   End If
  Next i
 End With
End Sub

Function XlsSheetToCombo(ByVal XlsName As String, Optional NoMsg As Boolean = False) As Boolean
'シート名取り出し
 Dim i As Integer, w As String
 On Error Resume Next

 Me!ComboBox1.Clear
 Err.Clear
 XlsName = Trim$(XlsName)
 If PathFileExists(XlsName) = 1 Then
  With Application
.   Workbooks.Open FileName:=XlsName, ReadOnly:=True
   For i = 1 To .ActiveWorkbook.Worksheets.Count
    Me!ComboBox1.AddItem .ActiveWorkbook.Worksheets(i).Name
   Next i
   XlsSheetToCombo = True
   If Err Then
    w = XlsName & "のシート名取り出しに失敗しました。"
   Else
    If NoMsg = False Then
     MsgBox "リストからシート名を指定してください。", vbInformation, cPrgName
     Me!ComboBox1.ListIndex = 0
     Me!ComboBox1.SetFocus
    End If
   End If
  End With
 Else
  w = "ファイルの指定が違います。ファイルが見つかりません。"
 End If
 i = True
 If Me!ScrollBar1.Value Then Me!ScrollBar1.Value = 1

 With Me
  !ComboBox1.Enabled = i
  !TextBox2.Enabled = i
  !TextBox3.Enabled = i
  !TextBox4.Enabled = i
  !CommandButton3.Enabled = i
  !CommandButton4.Enabled = i
  !Frame1.Enabled = i
 End With
End Function

Private Sub ScrollBar1_Change()
'横スクロールバーチェンジ時
 On Error Resume Next
 ActiveSheet.Columns(Me!ScrollBar1.Value).Select
End Sub

Private Sub ScrollBar2_Change()
'縦スクロールバーチェンジ時
 Dim i As Integer
 Dim w As String

 w = ActiveCell.Address()
 w = Mid$(w, 2)
 i = InStr(w, "$")
 If i > 0 Then w = Left$(w, i - 1)
 Range(w & Val(Me!ScrollBar2.Value)).Select
End Sub

Private Sub TextBox1_Enter()
'読込ファイル名記録
 preText1 = Me!TextBox1.Value
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'読込ファイル存在チェック
 Dim w As String

 w = Trim$(Me!TextBox1.Value)
 If w > "" Then
  If PathFileExists(w) = 0 Then
   MsgBox "読込ファイルが存在しません。" & Error, vbCritical, cPrgName
  ElseIf Me!TextBox1.Value <> preText1 Then
   XlsSheetToCombo Me!TextBox1.Value
  End If
 End If
End Sub

Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'見出し行の行数入力チェック
 If Not IsNumeric(Me!TextBox2.Value) Then
  MsgBox "行数を入力してください。", vbCritical, cPrgName
  Cancel = True
 Else
  Me!TextBox3.Value = Me!TextBox2.Value + 1
  ScrollBar1MaxSet
 End If
End Sub

Private Sub ScrollBar1MaxSet()
'スクロールバー最大値とスクロール量設定
 Me!ScrollBar1.Max = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
 Me!ScrollBar1.LargeChange = Me!ScrollBar1.Max \ 10 + 1
 Me!ScrollBar2.Max = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
 Me!ScrollBar2.LargeChange = Me!ScrollBar2.Max \ 10 + 1
End Sub

Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'データ開始行の行数入力チェック
 If Not IsNumeric(Me!TextBox3.Value) Then
  MsgBox "行数を入力してください。", vbCritical, cPrgName
  Cancel = True
 ElseIf Val(Me!TextBox3.Value) <= Val(Me!TextBox2.Value) Then
  MsgBox "データ行は見出し行より大きくしてください。", vbCritical, cPrgName
  Me!TextBox3.Value = Me!TextBox2.Value + 1
 End If
End Sub

Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'データ終了行の行数入力チェック
 If Not IsNumeric(Me!TextBox4.Value) Then
  MsgBox "行数を入力してください。", vbCritical, cPrgName
  Me!TextBox4.Value = ""
 ElseIf Val(Me!TextBox4.Value) <> 0 And Val(Me!TextBox4.Value) <= Val(Me!TextBox3.Value) Then
  MsgBox "データ終了行はデータ開始行より大きくしてください。データ終了行を指定しない場合は何も入力しないでください。",   vbCritical, cPrgName
  Me!TextBox4.Value = ""
 End If
End Sub

Private Function LsGetPath(FullPath As String, FileName As String) As String
'機能 : フルパス名から Path名 とファイル名を取得する
'引数 : FullPath = 取得したいファイル名のフルパス名
'戻り値: Path名 ファイル名

 Const MAX_PATH = 5120
 Dim StrBuf As String, longret As Long

 StrBuf = Space$(MAX_PATH)

 If GetFileTitle(FullPath, StrBuf, MAX_PATH) = 0 Then
  FileName = Left$(StrBuf, InStr(StrBuf, vbNullChar) - 1)
  LsGetPath = Left$(FullPath, Len(FullPath) - Len(FileName) - 1)
 End If
End Function

Private Sub UserForm_Initialize()
'口座振替用の全銀項目を設定
 選択項目(1, 6) = "*"
 選択項目(1, 14) = ""
 選択項目(1, 15) = "*"
 選択項目(1, 16) = "*"
 選択項目(1, 17) = "*"
 選択項目(0, 2) = "振替銀行番号"
 選択項目(0, 1) = "データ区分"
 選択項目(0, 3) = "振替銀行名"
 選択項目(0, 4) = "*振替支店番号"
 選択項目(0, 5) = "振替支店名"
 選択項目(0, 6) = "手形交換所番号"
 選択項目(0, 7) = "*預金種目"
 選択項目(0, 8) = "*口座番号"
 選択項目(0, 9) = "*振替人名"
 選択項目(0, 10) = "*振替金額"
 選択項目(0, 11) = "新規コード"
 選択項目(0, 12) = "顧客コード1"
 選択項目(0, 13) = "顧客コード2"
 選択項目(0, 14) = "振替結果"
 選択項目(0, 15) = "EDI識別表示"
 選択項目(0, 16) = "EDI情報"
 選択項目(0, 17) = "手数料区分"
 ListBox1Set

 ComboBox1_Click
 On Error Resume Next
 If Me!ScrollBar1.Value Then Me!ScrollBar1.Value = 1
 On Error GoTo 0
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'フォームが閉じられたら読込ファイルのブックを閉じる
 On Error Resume Next
 ActiveWorkbook.Close SaveChanges:=False
End Sub
ABConv_Ref.xlsのダウンロード(ABConv_Ref.LZH)

(UPD:02/12/07)