Excel VBA ファイル操作

Option Explicit
Option Base 1

Dim 対象ファイル名 As String   'フルパス
Dim 処理中ファイル名 As String 'フルパス
Dim シート名 As String
Dim マスタ配列 As Variant
Dim 最終行 As Long
Dim 処理行 As Long

Const cnsProvider = "Microsoft.ACE.OLEDB.12.0"
Const cnsExtProp = "Extended Properties"
Const cnsExcel = "Excel 12.0;HDR=YES"


'*******************************************************************************
' シートをテーブルとして内容を更新する
'*******************************************************************************
Sub ADO_WS_TEST2()
   Dim ADODB接続 As ADODB.Connection
   Dim ADODBレコードセット As ADODB.Recordset
   Dim SQL文 As String
   Dim 金額 As Long
   Dim 最終行 As Integer
   Dim 修正データ配列() As Variant
   Dim 修正品目索引 As Object        'Scripting.Dictionary オブジェクト
   
   ThisWorkbook.Worksheets("Sheet1").Activate
   対象ファイル名 = Range("B1").Value
   対象ファイル名 = ThisWorkbook.Path & "\" & 対象ファイル名 ' フルパスに変更
   シート名 = Range("B2").Value
   
   '修正単価データを読み込む
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   If 最終行 > 20 Then
      修正データ配列 = Range("A21").Resize(最終行 - 20, 2).Value
      
      Set 修正品目索引 = CreateObject("Scripting.Dictionary")    '★連想配列の定義

      For 処理行 = 1 To 最終行 - 20
         修正品目索引(修正データ配列(処理行, 1)) = 処理行
      Next 処理行
   End If
   
   Call 排他制御
   
   
   ' Connection生成
   Set ADODB接続 = New ADODB.Connection
   With ADODB接続
       .Provider = cnsProvider
       .Properties(cnsExtProp) = cnsExcel
       .Open 処理中ファイル名  'フルパス
   End With
   
   SQL文 = "SELECT * FROM [" & シート名 & "$]"
   ' RecordSet取得(更新用)
   Set ADODBレコードセット = New ADODB.Recordset
   
   ADODBレコードセット.Open SQL文, ADODB接続, adOpenKeyset, adLockOptimistic

    
   ' 一行ずつ読み出して、更新する
   Do Until ADODBレコードセット.EOF
      
      '修正単価がある場合
      If 最終行 > 20 Then
        If 修正品目索引.Exists(ADODBレコードセット.Fields("品目番号").Value) = True Then
            ADODBレコードセット.Update "単価", 修正データ配列(修正品目索引(ADODBレコードセット.Fields("品目番号").Value), 2)
            ADODBレコードセット.Update "備考", "単価修正"
         End If
      End If
      
      ' 金額と数量を取得
      If IsNull(ADODBレコードセット.Fields("単価").Value) = False Then
         If IsNull(ADODBレコードセット.Fields("数量").Value) = False Then

            ' 金額を計算
            金額 = WorksheetFunction.Round(ADODBレコードセット.Fields("単価").Value _
            * ADODBレコードセット.Fields("数量").Value, 0)
      
            ' 金額を更新
            ADODBレコードセット.Update "金額", 金額
         Else
            ' 備考を更新
             ADODBレコードセット.Update "備考", ADODBレコードセット.Fields("備考").Value & " 数量未登録"
         End If
      Else
         ' 備考を更新
         ADODBレコードセット.Update "備考", "単価未登録"
      End If
      '次の行に進む
      ADODBレコードセット.MoveNext
   Loop

   ' 終了処理
    
   ADODBレコードセット.Close
   Set ADODBレコードセット = Nothing
   ADODB接続.Close
   Set ADODB接続 = Nothing
   
   Name 処理中ファイル名 As 対象ファイル名
   
   MsgBox "更新を終了しました！"
    
End Sub

Private Sub 排他制御()

   Dim MyFile As String
   
   On Error GoTo ErrorTrap
   'ファイルがあるか確認
   MyFile = Dir(対象ファイル名) 'フルパスでチェック
   If MyFile = "" Then
       MsgBox "指定したファイルはありません"
   Else
      '書き込み専用でオープン
      Open 対象ファイル名 For Binary Lock Read Write As #1
      Close #1
   
      処理中ファイル名 = ThisWorkbook.Path & "\使用中のため開かないでね.xlsx"
      Name 対象ファイル名 As 処理中ファイル名

   End If
   
   Exit Sub
    
ErrorTrap:
   MsgBox Err & Error(Err)
   MsgBox "このファイルは使用中です"
   End
End Sub

Option Base 1

Sub CSVの拡張子をTEXに変更してテキスト読み込み()

   Dim CSVファイル名 As String
   Dim CSVファイルパス As String
   Dim 保存フォルダパス As String
   Dim TXTファイルパス As String
   Dim 保存フォルダ As String
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 列項目数 As Integer
   Dim 最終行 As Integer
   Dim 列項目配列() As Variant 'CSV のデータ項目とデータ形式を指定する配列
   Dim 処理項目数 As Integer
   Dim XlColumnDataType列挙 As Integer
   Dim データ形式 As String
   Dim 保存Excelブック名 As String
   Dim 保存フォルダのレベル As Integer
   Dim パス As String
   Dim レベル As Integer


   開始日時 = Now 'マクロの開始時刻を変数に格納

   ThisWorkbook.Worksheets("Sheet1").Activate 'パラメータを読み込むシートを開く

   CSVファイル名 = Range("D7").Value

   保存Excelブック名 = Left(CSVファイル名, InStrRev(CSVファイル名, ".") - 1)

   保存フォルダパス = Range("D8").Value

   最終行 = Cells(ActiveSheet.Rows.Count, 2).End(xlUp).Row 'B列の最終セルで行数をカウント
   列項目数 = 最終行 - 10
   ReDim 列項目配列(列項目数) 'CSV のデータ項目とデータ形式を指定する配列

   For 処理項目数 = 1 To 列項目数

      データ形式 = Range("B11").Cells(処理項目数, 1).Value

      Select Case データ形式
         Case "G/標準"
            XlColumnDataType列挙 = 1
         Case "文字列"
            XlColumnDataType列挙 = 2
         Case "日付"
            XlColumnDataType列挙 = 5
         Case Else
            Stop
            MsgBox "データ形式エラー"
      End Select

      列項目配列(処理項目数) = Array(処理項目数, XlColumnDataType列挙)
   Next 処理項目数

   CSVファイルパス = ThisWorkbook.Path & "\" & CSVファイル名

   'CSVファイルを、拡張子txt に変更してコピー
   TXTファイルパス = Left(CSVファイルパス, InStrRev(CSVファイルパス, ".")) & "txt"

   FileCopy CSVファイルパス, TXTファイルパス

   'TXT ファイルを、Excelに読み込む
   Workbooks.OpenText _
   Filename:=TXTファイルパス _
   , Origin:=932 _
   , StartRow:=1 _
   , DataType:=xlDelimited _
   , TextQualifier:=xlDoubleQuote _
   , ConsecutiveDelimiter:=False _
   , Tab:=False _
   , Semicolon:=False _
   , Comma:=True _
   , Space:=False _
   , Other:=False _
   , FieldInfo:=列項目配列 _
   , TrailingMinusNumbers:=True


   ' 保存フォルダパスがなければ作る
   保存フォルダのレベル = 出現回数(保存フォルダパス, "\\")

   For レベル = 1 To 保存フォルダのレベル
      If レベル < 保存フォルダのレベル Then
         パス = Left(保存フォルダパス, 出現位置(保存フォルダパス, "\\", レベル + 1))
      Else
         パス = 保存フォルダパス
      End If

      If Dir(パス, vbDirectory) = "" Then
          MkDir パス
      End If
   Next レベル

   Application.DisplayAlerts = False '変更を保存しますか? のメッセージを表示させない
   'Excelブックとして保存する
   ActiveWorkbook.SaveAs _
      Filename:=保存フォルダパス & "\" & 保存Excelブック名 & ".xls" _
      , FileFormat:=xlWorkbookNormal
   ActiveWorkbook.Close

   Application.DisplayAlerts = True

   '作業用に作成した拡張子 txt のファイルを削除
   Kill TXTファイルパス

   終了日時 = Now

   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Array(Array(3, 3), Array(1, 2))

Workbooks.OpenText filename:="DATA.TXT", _
    dataType:=xlDelimited, tab:=True

' ファイル TESTFILE には、データが含まれているものと仮定します。
Kill "TestFile"                ' ファイルを削除します。

' 現在のフォルダにあるすべての *.TXT ファイルを削除します。
Kill "*.TXT"