ADOconnection

FSOの一部のメソッドだけのクラスsafeFolderObj

Option Explicit

Private fso As Object

Public path As String

Public Function getSubfolders() As Object
  Set getSubfolders = fso.GetFolder(path).Subfolders
End Function

Public Function copyFile(ByVal filePath As String, ByVal afterPath As String)
  fso.copyFile filePath, afterPath
End Function

Private Sub Class_Initialize()
  Set fso = CreateObject("Scripting.FileSystemObject")
End Sub

サブフォルダからファイルを取り出し集める

Option Explicit

Sub collectPDFsFromSubfolders()
  Application.ScreenUpdating = False
  Const workFolderPath = " "
  Dim folderObj As New safeFolderObj
  Dim subfolder As Object

  folderObj.path = workFolderPath  
  If ThisWorkbook.path <> workFolderPath Then
    MsgBox "このブックを指定のフォルダに置いてから実行してください。"
    Exit Sub
  End If
  
  For Each subfolder In folderObj.getSubfolders
    On Error Resume Next
    folderObj.copyFile subfolder.path & "\*.pdf", workFolderPath
    On Error GoTo 0
  Next
End Sub

タイトル行を削除して返す関数

Function deheader(ByRef dataRange As Range) As Range
  Dim rowsCount
  Dim columnsCount
  rowsCount = dataRange.Rows.Count
  columnsCount = dataRange.Columns.Count
    
  Set deheader = dataRange.Offset(1,0).Resize(rowsCount -1,columnsCount)
End Function

Rangeを1次元配列に変換する関数

Option Explicit

Function rangeTo1DArray(ByRef targetRange As Range) As Variant
  Dim count As Integer, i As Integer
  Dim arr() As Variant
  count = targetRange.count
  ReDim arr(1 To count)
  
  For i = 1 To count
    arr(i) = targetRange(i).value
  Next

  rangeTo1DArray = arr
End Function


Sub pasteJoinedRowset()
  Application.ScreenUpdating = False
  Dim rangePaste As Range
  Dim rangeRowset As Range
  Dim joinedText As String
  Set rangePaste = Range("C1")
  Set rangeRowset

  joinedText = Join(rangeTo1DArray(rangeRowset), ",")
  rangePaste.value = joinedText
End Sub

2次元配列を扱うクラスarrayObj

Option Explicit

Public array2D As Variant

Private Property Get lb1() As Integer
  lb1 = LBound(array2D)
End Property

Private Property Get ub1() As Integer
  ub1 = UBound(array2D)
End Property

Private Property Get lb2() As Integer
  lb2 = LBound(array2D, 2)
End Property

Private Property Get ub2() As Integer
  ub2 = UBound(array2D, 2)
End Property

Public Function index(ByRef arr() As Variant) As Integer 'arr()は1次元配列　ここは「paramArray arr()」でもよい
  Dim number As Integer: number = -1
  Dim equalsElement As Boolean, i As Integer, j As Integer
  
  For i = lb1 To ub1
    equalsElement = True
    For j = lb2 To ub2
      equalsElement = equalsElement * (array2D(i, j) = arr(j))
    Next
    If equalsElement Then
      number = i
      Exit For
    End If
  Next
  
  index = number
End Function

'Public Sub Class_Initialize()
'  array2D = Empty
'End Sub

Public Function toRowsetDictionary(paramArray keys()) As Object()
  Dim arr() As Object
  Dim i As Integer, j As Integer, value As Variant
  
  ReDim arr(lb1 To ub1)
  
  For i = lb1 To ub1
    Dim eachDictionary: Set eachDictionary = CreateObject("Scripting.Dictionary")
    For j = lb2 To ub2
      value = array2D(i, j)
      eachDictionary.Add keys(j - 1), value
    Next
    Set arr(i) = eachDictionary
    Set eachDictionary = Nothing
  Next
  toRowsetDictionary = arr
End Function

Public Function map(ByVal method As String) As Variant
  Dim arr() As Variant
  Dim i As Integer, j As Integer, n As Integer
  
  ReDim arr(1 To (ub1 - lb1 + 1) * (ub2 - lb2 + 1))
  
  n = 1
  For i = lb1 To ub1
    For j = lb2 To ub2
      arr(n) = Application.Run(method, array2D(i, j))
      n = n + 1
    Next
  Next
  map = arr
End Function

​​リンクテーブルのリンク元変更

Sub update_tablelink()
​​    Dim table As TableDef
​​    Dim tablelink As String, newTablelink As String
​​    Dim substitutedText As String, setText As String
​​
​​    substitutedText = "〇〇"  '置換する文字列部分
​​    setText = "〇〇"    '新しい文字列部分
​​
​​    For Each table In CurrentDb.TableDefs   'すべてのテーブルで
​​        If table.Attributes And dbAttachedTable Then   'リンクテーブルなら
​​            tablelink = table.Connect   '接続文字列を取得
​​            newTablelink = Replace(tablelink, substitutedText, setText)
​​            If tablelink <> newTablelink Then   '置換されていたら
​​                table.Connect = newTablelink
​​                table.RefreshLink   'リンクを更新
​​            End If
​​        End If
​​    Next
​​End Sub

new_compare_table

​​Sub ADO_compare_records()
​​  Application.ScreenUpdating = False
​​  Worksheets("table_content").Cells.Clear
​​  
​​  Dim comparedTableName As Range
​​  Dim recordNumber As Range
​​  Dim connection As Object
​​  Dim recordset1 As Object, recordset2 As Object
​​  Dim fieldCount As Integer, sql1 As String, sql2 As String, deleteSql1 As String, deleteSql2 AsString
​​  Dim i As Integer
​​  
​​  Set comparedTableName = Range("E4")
​​  Set recordNumber = Range("I5")
​​  Set connection = CreateObject("ADODB.Connection")
​​  Set recordset1 = CreateObject("ADODB.Recordset")
​​  Set recordset2 = CreateObject("ADODB.Recordset")
​​
​​  'ADO接続
​​  connection.Provider = "Microsoft.ACE.OLEDB.12.0"
​​  connection.Properties("Extended Properties") = "Excel 12.0;HDR=Yes"
​​  connection.Open ThisWorkbook.Path & "\" & "Database.xlsx"
​​
​​  'SQL文の実行
​​​​  sql1 = "SELECT * FROM " & comparedTableName.Offset(1, 0).Value & " WHERE TESTROW IN (" & recordNumber.Value & ");"
​​  ​​sql2 = "SELECT * FROM " & comparedTableName.Offset(2, 0).Value & " WHERE TESTROW IN (" & recordNumber.Value & ");"
​​  ​​recordset1.Open sql1, connection
​​​​  recordset2.Open sql2, connection
​​​​  fieldCount = recordset.Fields.Count
​​
​​​​  Do Until recordset1.EOF
​​  ​​  セル.CopyFromRecordset recordset1
​​  ​​  セル.CopyFromRecordset recordset2
  ​​  'recordset1("TESTROW")
  ​​  'recordset2("TESTROW")

​​  ​​  recordset1.MoveNext
​​  ​​  recordset2.MoveNext
​​  ​​Loop
​​    
​​​​  recordset1.Close
​​  ​​recordset2.Close
​​
​​  deleteSql1 = "ALTER TABLE " & comparedTableName.Offset(1,0).Value & " DROP TESTROW;"
​​​​  deleteSql2 = "ALTER TABLE " & comparedTableName.Offset(2,0).Value & " DROP TESTROW;"
​​  '​​connection.Execute deleteSql1
​​  '​​connection.Execute deleteSql2
​​  ​​connection.Close