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"

Option Explicit


'URLDownloadToFile API from URLMON.
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal _
szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Dim ファイルシステムオブジェクト      As Object          ' FileSystemObject
    
Sub 指定拡張子ファイルの文字コード一覧()

'   Dim ファイルシステムオブジェクト As Object          ' FileSystemObject
   Dim ファイルオブジェクト As Object
   Dim フォルダパス As String
   Dim ファイルパス As String
   Dim 拡張子 As String
   Dim ファイル名 As String
   Dim 文字コード As String
   Dim カウンタ As Integer
   Dim 最終行 As Integer
   Dim Stime As Variant
   Dim Etime As Variant
   
   Stime = Now()
   Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")

   拡張子 = ThisWorkbook.Worksheets("Sheet1").Range("B3").Value
   カウンタ = 0

   'このブックのパスを対象フォルダとして特定
   フォルダパス = ThisWorkbook.Path
   
   '既存データの2行目以降を行削除する
   Worksheets("Sheet1").Activate
   'A 列(1列目)を基準に、最終行を求める
   最終行 = Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row
   If 最終行 > 5 Then
      Rows(6 & ":" & 最終行).Delete Shift:=xlUp '単純な Cells.Clear だとムダな空白行が残ってしまう
   End If

   '上で指定したフォルダ内の、全ての対象拡張子を検索
    For Each ファイルオブジェクト In ファイルシステムオブジェクト.GetFolder(フォルダパス).Files

      If ファイルシステムオブジェクト.GetExtensionName(ファイルオブジェクト.Name) Like 拡張子 Then

         ファイル名 = ファイルオブジェクト.Name
         文字コード = GetCharSetOfText(フォルダパス, ファイル名)
         カウンタ = カウンタ + 1
         Worksheets("Sheet1").Range("A6").Cells(カウンタ, 1).Value = ファイル名
         Worksheets("Sheet1").Range("B6").Cells(カウンタ, 1).Value = 文字コード
         '進捗状況をステータスバーに表示
         Application.StatusBar = ファイル名
         
      End If
   Next ファイルオブジェクト
   
   Set ファイルオブジェクト = Nothing
   Set ファイルシステムオブジェクト = Nothing

   Etime = Now()
   Application.StatusBar = "★抽出ファイル数= " & カウンタ & " ★"
   MsgBox "処理が終了しました。抽出ファイル数= " & カウンタ & Chr(13) _
   & "処理時間は、" & Format(Etime - Stime, "hh時間nn分ss秒") & " でした。", vbOKOnly

End Sub

' ************************************************************
'  http://3335.blog106.fc2.com/blog-entry-141.html
'  Excel2003：VBAで､テキストファイルの文字コードを自動判定
'  参照設定：Microsoft Scripting Runtime
' ************************************************************
Function GetCharSetOfText(ByVal 引数フォルダパス As String, _
                          ByVal 引数ファイル名 As String) As String
                           
    ' リネーム用拡張子
    Const テキスト拡張子 = ".txt"
     
'    Dim ファイルシステムオブジェクト      As Object
    Dim ファイル     As Object
    Dim Htmlファイル As Object
     
    Dim 文字コード     As String
    Dim 判定文字コード As String
     
    Dim tmpVbName   As String
    Dim tmpTextName As String
     
'    Set ファイルシステムオブジェクト = CreateObject("Scripting.FileSystemObject")
    Set ファイル = ファイルシステムオブジェクト.GetFile(引数フォルダパス & "\" & 引数ファイル名)
     
       ' TEMPフォルダにコピー後、htmlファイルとして
       ' ファイル情報を再取得
       tmpVbName = Environ("TEMP") & "\" & 引数ファイル名
       'Environ 関数はオペレーティング システムの環境変数に関連付けられた String を返します。
       'https://learn.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/environ-function
   '    Stop
       tmpTextName = tmpVbName & テキスト拡張子
        
       ' 万が一の残存ファイル削除
       If ファイルシステムオブジェクト.FileExists(tmpVbName) Then
           Call ファイルシステムオブジェクト.DeleteFile(tmpVbName, True)
       End If
       If ファイルシステムオブジェクト.FileExists(tmpTextName) Then
           Call ファイルシステムオブジェクト.DeleteFile(tmpTextName, True)
       End If
        
       ' 作業用ファイル複写
       ファイル.Copy (tmpVbName)
       Set ファイル = ファイルシステムオブジェクト.GetFile(tmpVbName)
        
       ' リネームし、ファイル情報を再取得
       ファイル.Name = ファイル.Name & テキスト拡張子
       Set Htmlファイル = GetObject(ファイル.Path, "htmlfile")
        
       Do While Htmlファイル.readyState <> "complete"
           Application.Wait Now + TimeSerial(0, 0, 1)
           DoEvents
       Loop
        
       ' 文字コード取得
       文字コード = LCase(Htmlファイル.Charset)
    
    Select Case 文字コード

        Case "utf-8", "euc-jp", "shift_jis", "unicode", "gb2312"
        '<META HTTP-EQUIV="Content-Type" CONTENT="text/html;charset=gb2312">
            ' ツールで想定している文字コード
            判定文字コード = 文字コード
         
        Case Else
            ' 上記以外は弾いておく
            判定文字コード = ""
         
    End Select
     
    ' 作業用ファイル削除
    ファイル.Delete
   Set ファイル = Nothing
   Set Htmlファイル = Nothing
'    Set ファイルシステムオブジェクト = Nothing

    GetCharSetOfText = 判定文字コード

End Function