編集履歴

質問編集履歴

説明追加

2019/11/02 04:35

投稿

hachi3156

スコア16

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -178,123 +178,281 @@
 End Sub
-Public Sub ReadDBData(ByVal TarObjToWRITE As String, ByRef ReadList() As Variant, ByRef WriteList() As Variant, ByVal strSQL As String)
-    Dim CntRow As Long
-    Dim readobj As Object
-    Dim writeobj As Object
+```
+###クラスモジュール３ returnObject
+```
+・クラス変数
+Public Cls_ws As Worksheet
+Public Cls_ADORes As ADODB.Recordset
+Public Cls_Frm As UserForm
+Public Function SetObjToRead(ByVal strTarObj As String, ByRef Cls_strArrForSetObj() As Variant, ByVal TarCol As Long, Optional TarRowForCell As Long = 1) As Object
+    'データを読み込む(コピーする)オブジェクトを選択
+    Select Case strTarObj
+        Case "CELL"
+            Set SetObjToRead = ObjCell(Cls_strArrForSetObj(TarCol), TarRowForCell)
+        Case "FIELD"
+            Set SetObjToRead = ObjField(Cls_strArrForSetObj(TarCol))
+        Case "CONTROL"
+            Set SetObjToRead = ObjControl(Cls_strArrForSetObj(TarCol))
+    End Select
+End Function
+Public Function SetObjToWrite(ByVal strTarObj As String, ByRef Cls_strArrForSetObj() As Variant, ByVal TarCol As Long, Optional TarRowForCell As Long = 1) As Object
+    'データを書き込む(ペーストする)オブジェクトを選択
+    Select Case strTarObj
+        Case "CELL"
+            Set SetObjToWrite = ObjCell(Cls_strArrForSetObj(TarCol), TarRowForCell)
+        Case "FIELD"
+            Set SetObjToWrite = ObjField(Cls_strArrForSetObj(TarCol))
+        Case "CONTROL"
+            Set SetObjToWrite = ObjControl(Cls_strArrForSetObj(TarCol))
+    End Select
+End Function
+Private Function ObjCell(ByRef Cls_strForSetObj As Variant, ByVal TarRow As Long) As Range
+    Set ObjCell = Cls_ws.Cells(TarRow, ColSlctByTitle(Cls_strForSetObj, Cls_ws))
+End Function
+```
+#修正
+追加の返信をいただく前に標準モジュールにしてしまいました。申し訳ないです。
+使用例：ワークシート→ユーザーフォーム間のデータのやりとり
+![イメージ説明](e6f1d9b8d456ff6e2fc80a3a80203e8a.png)
+アクティブシートのデータを取得したい行を「行番号」のテキストボックスに入力してから、「コピー元決定」ボタンを押すとcmdC_DecideParts_Clickが動きます
+データのやりとりを行うオブジェクトはSetObjToRead関数とSetObjToWrite関数で決めており、どのオブジェクトのどの要素をやりとりの対象とするのかを文字列として渡すことで目的のオブジェクトを決めています。
+(例：データを読み込みたい(値をコピーしたい)オブジェクトをアクティブシートの7行目にある品番列のRangeオブジェクトにする場合)
+→strTarObjName="CELL"、TarRowForCell=7,strTarElement="品番",TarObj=ActivesheetをSetObjToRead関数に引数として渡す
+セルをデータのやり取りの対象にしたい場合は単純に列番号を渡すと列の順番を変更できないので、さらにcolslctbytitle関数に列名を文字列として渡して、渡した文字列とシートの列名が一致したらそのときの列番号をcolslctbytitle関数の返り値としています
+ReadArray(),WriteArray()ではSetObjToRead関数とSetObjToWrite関数に渡すための文字列を決めています
+現状はShtToFrm関数のように(データの読み込み先：Worksheet)To(データの書き込み先:UserForm)として関数の名前を付けていますが、6パターン文の関数(ShtToFrm,FrmToSht,ShtToAccessDB,AccessDBToSht,FrmToAccessDB,AccessDBToFrm)
+(データの書き込み先がAccessDBの場合は新規追加と更新もあるので、さらに関数が増えそう)
+を作るのではなく、2,3つの関数にまとめられたらと考えています。
+ユーザーフォームのモジュール(FrmCopyContentsInfoOfParts)
+```ここに言語を入力
+Private Sub cmdC_DecideParts_Click()
+    Dim TarRow As Integer
+    TarRow = Me.txtRowNum.Value
+    Dim ReadArray() As Variant
+    Dim WriteArray() As Variant
+    '配列の要素はそれぞれ対応していなければならない(e.g:品番⇔txtC_PartNum)
+    ReadArray() = Array("品番", "図番", "図番改定", "品名", "型式名", "アキクラコード", "メーカー名", "メーカーコード", "仕入先", "仕入先コード", "標準原価単価", "標準発注単価", _
+                        "ロット発注", "ロット単位数", "部品_在庫小数桁", "在庫用発注_棚卸変換値", "標準発注LT", "製番製品No_ロットNo", _
+                        "部品単位", "発注単位", "品番分類", "在庫分類", "発注手配", "引当手配", "品番備考")
+    WriteArray() = Array("txtC_PartNum", "txtC_ChartNum", "txtC_ChartNumRev", "txtC_Item", "txtC_Model", "txtC_AkikuraCode", "txtC_maker", "txtC_MakerCode", "txtC_Vendor", "txtC_VendorCode", "txtC_Price", "txtC_OrderPrice", _
+                        "txtC_Lot", "txtC_LotQty", "txtC_Digit", "txtC_ConversionValue", "txtC_LT", "txtC_LotNo", _
+                        "txtC_PartsUnit", "txtC_OrderUnit", "txtC_PartNumClassCode", "txtC_StockClassCode", "txtC_OrderArrgtCode", "txtC_AllocArrgtCode", "txtC_Remark")
+    Call ShtToFrm(ReadArray(), WriteArray(), TarRow)
+End Sub
+```
+以下、標準モジュール
+```ここに言語を入力
+Public Sub ShtToFrm(ByRef strArrayToRead() As Variant, ByRef strArrayToWrite() As Variant, ByVal TarRow As Long)
+    If UBound(strArrayToRead) <> UBound(strArrayToWrite) Then
+        MsgBox "読み込み先の配列の要素数と書き込み先の配列の要素数が違います" & vbCrLf & "処理を中止します"
+        Exit Sub
+    End If
+    Dim StartRow As Long
     Dim LengthOfArray As Long
-    Dim StartRow As Long
-    Dim EndRow As Long
+    Dim ReadObj As Object
-    Dim ADOCon As ADODB.Connection
-    Dim ADORes As ADODB.Recordset
-    Set ADOCon = initDb(ADODB_NAME, ADODB_PASS)
-    Set ADORes = New ADODB.Recordset
-    ADORes.Open strSQL, ADOCon
-    Dim reObj As returnObject
+    Dim WriteObj As Object
-    Set reObj = New returnObject
-    '----標準モジュール記載
-    Set reObj.Cls_ADORes = Createobject("ADODB.recordset")
-    Set reObj.Cls_Frm = UserForm1
-    '----
-    StartRow = 3
-    EndRow = 10
-    For CntRow = StartRow To EndRow
-        'リストの要素数
-        For LengthOfArray = LBound(ReadList) To UBound(ReadList)
+    For LengthOfArray = LBound(strArrayToRead) To UBound(strArrayToRead)
-            Set readobj = reObj.SetObjToRead("FIELD", ReadList(), LengthOfArray, CntRow)
+        Set ReadObj = SetObjToRead("CELL", ActiveSheet, strArrayToRead(LengthOfArray), TarRow)
-            Set writeobj = reObj.SetObjToWrite(TarObjToWRITE, WriteList(), LengthOfArray, CntRow)
+        Set WriteObj = SetObjToWrite("CONTROL", FrmCopyContentsInfoOfParts, strArrayToWrite(LengthOfArray))
-            writeobj.Value = readobj.Value
+        WriteObj.Value = ReadObj.Value
-        Next LengthOfArray
+    Next LengthOfArray
-    Next CntRow
 End Sub
-```
+```
+前回ではSetObjToReadやSetObjToWriteに配列を渡していたので、それを配列内の文字列を直接渡すようにしたのですが、こうしてみるとShtToFrmにも配列で渡す必要なかったですね
-###クラスモジュール３ returnObject
+そうすれば、forループを関数の外で処理できそうです
-```
+```ここに言語を入力
-・クラス変数
-Public Cls_ws As Worksheet
+Option Explicit
-Public Cls_ADORes As ADODB.Recordset
-Public Cls_Frm As UserForm
-Public Function SetObjToRead(ByVal strTarObj As String, ByRef Cls_strArrForSetObj() As Variant, ByVal TarCol As Long, Optional TarRowForCell As Long = 1) As Object
+Public Function SetObjToRead(ByVal strTarObjName As String, ByVal TarObj As Object, ByVal strTarElement As String, Optional TarRowForCell As Long = 1) As Object
     'データを読み込む(コピーする)オブジェクトを選択
+    On Error GoTo Err
-    Select Case strTarObj
+    Select Case strTarObjName
@@ -302,39 +460,55 @@
-            Set SetObjToRead = ObjCell(Cls_strArrForSetObj(TarCol), TarRowForCell)
+            Set SetObjToRead = TarObj.Cells(TarRowForCell, ColSlctByTitle(strTarElement, TarObj))
         Case "FIELD"
-            Set SetObjToRead = ObjField(Cls_strArrForSetObj(TarCol))
+            Set SetObjToRead = TarObj.Fields(strTarElement)
         Case "CONTROL"
-            Set SetObjToRead = ObjControl(Cls_strArrForSetObj(TarCol))
+            Set SetObjToRead = TarObj.Controls(strTarElement)
     End Select
+    Exit Function
+Err:
+    Call ErrHndl(Err.Number, Err.Description)
 End Function
-Public Function SetObjToWrite(ByVal strTarObj As String, ByRef Cls_strArrForSetObj() As Variant, ByVal TarCol As Long, Optional TarRowForCell As Long = 1) As Object
+Public Function SetObjToWrite(ByVal strTarObjName As String, ByVal TarObj As Object, ByVal strTarElement As String, Optional TarRowForCell As Long = 1) As Object
     'データを書き込む(ペーストする)オブジェクトを選択
+    On Error GoTo Err
-    Select Case strTarObj
+    Select Case strTarObjName
@@ -342,152 +516,124 @@
-            Set SetObjToWrite = ObjCell(Cls_strArrForSetObj(TarCol), TarRowForCell)
+            Set SetObjToWrite = TarObj.Cells(TarRowForCell, ColSlctByTitle(strTarElement, TarObj))
         Case "FIELD"
-            Set SetObjToWrite = ObjField(Cls_strArrForSetObj(TarCol))
+            Set SetObjToWrite = TarObj.Fields(strTarElement)
         Case "CONTROL"
-            Set SetObjToWrite = ObjControl(Cls_strArrForSetObj(TarCol))
+            Set SetObjToWrite = TarObj.Controls(strTarElement)
     End Select
+    Exit Function
+Err:
+    Call ErrHndl(Err.Number, Err.Description)
 End Function
-Private Function ObjCell(ByRef Cls_strForSetObj As Variant, ByVal TarRow As Long) As Range
+Private Sub ErrHndl(ByVal ErrNum As Long, ByVal ErrDiscription As Variant)
+    Select Case ErrNum
+        Case Else
+            MsgBox "エラー番号:" & Err.Number & vbCrLf & "エラーの種類:" & ErrDiscription
+    End Select
+End Sub
+```
+```ここに言語を入力
+Public Const StartRow = 5
+Public Function ColSlctByTitle(ByVal Title As String, ByVal ws As Worksheet, Optional ByVal DefaultRow As Integer = StartRow) As Integer
+    Dim CountCol As Integer
+    Dim titleRow As Integer
+    Dim MaxCol As Integer
+    titleRow = DefaultRow   ' タイトル行番号
+    With ws
-    Set ObjCell = Cls_ws.Cells(TarRow, ColSlctByTitle(Cls_strForSetObj, Cls_ws))
+        MaxCol = .Cells(DefaultRow, .Columns.Count).End(xlToLeft).Column
+        For CountCol = 1 To MaxCol
+            If .Cells(titleRow, CountCol).Text() = Title Then
+                ColSlctByTitle = CountCol
+                Exit Function      ' 正常終了
+            End If
+        Next
+    End With
+    'エラー終了
+    Err.Description = ws.Name & "のタイトル行に指定文字列( " + Title + " ) が見つかりませんでした"
+    Err.Raise (60000)
+    MsgBox (Err.Description)
 End Function
-```
+```
-###標準モジュール
-```
-Public Function ColSlctByTitle(ByVal Title As String, ByVal ws As Worksheet, Optional ByVal DefaultRow As Integer = StartRow) As Integer
-    Dim CountCol As Integer
-    Dim titleRow As Integer
-    Dim MaxCol As Integer
-    titleRow = DefaultRow   ' タイトル行番号
-    With ws
-        MaxCol = .Cells(DefaultRow, .Columns.Count).End(xlToLeft).Column
-        For CountCol = 1 To MaxCol
-            If .Cells(titleRow, CountCol).Text() = Title Then
-                ColSlctByTitle = CountCol
-                Exit Function      ' 正常終了
-            End If
-        Next
-    End With
-    'エラー終了
-    Err.Description = ws.Name & "のタイトル行に指定文字列( " + Title + " ) が見つかりませんでした"
-    Err.Raise (60000)
-    MsgBox (Err.Description)
-End Function
-Public Function initDb(ByVal FileName As String, ByVal FilePass As String) As ADODB.Connection
-    Dim ConnectionString As String          '接続文字列
-    Dim DbFilePass As String                'データベースファイルのパス
-    Dim DbFileName As String                'データベースファイルの名前
-    Dim ADOCon As ADODB.Connection          'データベース接続オブジェクト
-    Dim strCon As String
-    '接続文字列作成
-    ConnectionString = "Microsoft.ACE.OLEDB.12.0"
-    DbFileName = FileName & ".accdb"
-    Set ADOCon = New ADODB.Connection
-    ' 接続文字列を作成する
-    strCon = "Provider=" & ConnectionString & ";" & "Data Source=" & FilePass & DbFileName & ";"
-    '接続する
-    ADOCon.Open strCon
-    Set initDb = ADOCon
-End Function
-```