· 5 years ago · Feb 13, 2020, 06:30 AM
1Merge two records into one record
2
3Option Compare Database
4
5Sub Merge_Record()
6
7 'OBJECTIVE: to build a table by extracting some fields from a main database
8
9 Dim rst As Recordset
10 Dim rs As Recordset
11 Dim strSQL As String
12 Dim tablename As String
13 Dim intCount As Integer
14 Dim intNumFields As Integer
15
16 Dim i As Integer
17 Dim strRecords() As String
18 Dim strFields As String
19
20 Dim intStatus As Integer
21 'A query to a "main frame computer"
22 strSQL = "SELECT DISTINCT 個人コード, 住所変更対象 FROM T_国民年金第３号住所変更届temp"
23
24 Set rst = CurrentDb.OpenRecordset(strSQL)
25 intCount = rst.RecordCount - 1
26 Do While Not rst.EOF 'Do While Records are there
27 StrID = rst!個人コード
28
29
30 If rst!住所変更対象 = "被保険者" Or rst!住所変更対象 = "被保険者及び被扶養配偶者" Then
31 strQuery = "SELECT * FROM T_国民年金第３号住所変更届temp as X WHERE (((X.個人コード)=" & StrID & ")) ORDER BY X.被保険者の変更年月日 DESC;"
32 ElseIf rst!住所変更対象 = "被扶養配偶者" Then
33 strQuery = "SELECT * FROM T_国民年金第３号住所変更届temp as X WHERE (((X.個人コード)=" & StrID & ")) ORDER BY X.配偶者住所変更年月日 DESC;"
34 End If
35 'Write String to Query
36 CurrentDb.QueryDefs("xyz").SQL = strQuery
37 Set rs = CurrentDb.OpenRecordset(strQuery)
38
39 'LOAD ARRAY FOR FIELD NAMES FROM THE RST
40
41 'FIND THE # OF RECORDS IN THIS SET...
42 rs.MoveLast
43 rs.MoveFirst
44
45 'Total number of records in this recordset
46 intCount = rs.RecordCount - 1 '0-based
47 i = 0
48
49 intNumFields = rs.Fields.Count
50
51 If rs!住所変更対象 = "被保険者" Or rs!住所変更対象 = "被保険者及び被扶養配偶者" Then
52
53 'strFields = rst.Fields(0).Name 'for 1 field name
54 strFields = rs.Fields(0).Name & "," & rs.Fields(1).Name & "," & rs.Fields(2).Name & "," & rs.Fields(3).Name & "," & rs.Fields(4).Name & "," & rs.Fields(5).Name & "," & rs.Fields(6).Name & "," & rs.Fields(7).Name & "," & rs.Fields(8).Name & "," & rs.Fields(9).Name & "," & rs.Fields(10).Name & "," & rs.Fields(11).Name & "," & rs.Fields(12).Name & "," & rs.Fields(13).Name & "," & rs.Fields(14).Name & "," & rs.Fields(15).Name & "," & rs.Fields(16).Name & "," & rs.Fields(17).Name & "," & rs.Fields(18).Name & "," & rs.Fields(19).Name & "," & rs.Fields(20).Name & "," & rs.Fields(21).Name & "," & rs.Fields(22).Name & "," & rs.Fields(23).Name & "," & rs.Fields(24).Name & "," & rs.Fields(25).Name & "," & rs.Fields(26).Name & "," _
55 & rs.Fields(27).Name & "," & rs.Fields(28).Name & "," & rs.Fields(29).Name & "," & rs.Fields(30).Name & "," & rs.Fields(31).Name & "," & rs.Fields(32).Name & "," & rs.Fields(33).Name & "," & rs.Fields(34).Name & "," & rs.Fields(35).Name & "," & rs.Fields(36).Name & "," & rs.Fields(37).Name & "," & rs.Fields(38).Name & "," & rs.Fields(39).Name & "," & rs.Fields(40).Name & "," & rs.Fields(41).Name & "," & rs.Fields(42).Name & "," & rs.Fields(43).Name & "," & rs.Fields(44).Name & "," & rs.Fields(45).Name & "," & rs.Fields(46).Name & "," & rs.Fields(47).Name & "," & rs.Fields(48).Name & "," & rs.Fields(49).Name & "," & rs.Fields(50).Name
56
57 'Store the values of the query in an array...
58 ReDim Preserve strRecords(i)
59
60 'strRecords(i) = rst.Fields(0) 'for 1 field
61 strRecords(i) = rs.Fields(0) & "," & rs.Fields(1) & "," & rs.Fields(2) & "," & rs.Fields(3) & "," & rs.Fields(4) & "," & rs.Fields(5) & "," & rs.Fields(6) & "," & rs.Fields(7) & "," & rs.Fields(8) & "," & rs.Fields(9) & "," & rs.Fields(10) & "," & rs.Fields(11) & "," & rs.Fields(12) & "," & rs.Fields(13) & "," & rs.Fields(14) & "," & rs.Fields(15) & "," & rs.Fields(16) & "," & rs.Fields(17) & "," & rs.Fields(18) & "," & rs.Fields(19) & "," & rs.Fields(20) & "," & rs.Fields(21) & "," & rs.Fields(22) & "," & rs.Fields(23) & "," & "" & "," & rs.Fields(25) & "," & rs.Fields(26) & "," _
62 & rs.Fields(27) & "," & rs.Fields(28) & "," & rs.Fields(29) & "," & rs.Fields(30) & "," & rs.Fields(31) & "," & rs.Fields(32) & "," & rs.Fields(33) & "," & rs.Fields(34) & "," & rs.Fields(35) & "," & rs.Fields(36) & "," & rs.Fields(37) & "," & rs.Fields(38) & "," & rs.Fields(39) & "," & rs.Fields(40) & "," & rs.Fields(41) & "," & rs.Fields(42) & "," & rs.Fields(43) & "," & rs.Fields(44) & "," & "" & "," & rs.Fields(46) & "," & rs.Fields(47) & "," & rs.Fields(48) & "," & rs.Fields(49) & "," & rs.Fields(50)
63
64 'Debug.Print strRecords(i)
65
66 i = i + 1
67 rs.MoveNext
68 ReDim Preserve strRecords(i)
69 strRecords(i) = rs.Fields(0) & "," & rs.Fields(1) & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & rs.Fields(23) & "," & rs.Fields(25) & "," & "" & "," _
70 & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & rs.Fields(44) & "," & rs.Fields(46) & "," & "" & "," & "" & "," & "" & "," & ""
71
72 ElseIf rs!住所変更対象 = "被扶養配偶者" Then
73 strFields = rs.Fields(0).Name & "," & rs.Fields(1).Name & "," & rs.Fields(2).Name & "," & rs.Fields(3).Name & "," & rs.Fields(4).Name & "," & rs.Fields(5).Name & "," & rs.Fields(6).Name & "," & rs.Fields(7).Name & "," & rs.Fields(8).Name & "," & rs.Fields(9).Name & "," & rs.Fields(10).Name & "," & rs.Fields(11).Name & "," & rs.Fields(12).Name & "," & rs.Fields(13).Name & "," & rs.Fields(14).Name & "," & rs.Fields(15).Name & "," & rs.Fields(16).Name & "," & rs.Fields(17).Name & "," & rs.Fields(18).Name & "," & rs.Fields(19).Name & "," & rs.Fields(20).Name & "," & rs.Fields(21).Name & "," & rs.Fields(22).Name & "," & rs.Fields(23).Name & "," & rs.Fields(24).Name & "," & rs.Fields(25).Name & "," & rs.Fields(26).Name & "," _
74 & rs.Fields(27).Name & "," & rs.Fields(28).Name & "," & rs.Fields(29).Name & "," & rs.Fields(30).Name & "," & rs.Fields(31).Name & "," & rs.Fields(32).Name & "," & rs.Fields(33).Name & "," & rs.Fields(34).Name & "," & rs.Fields(35).Name & "," & rs.Fields(36).Name & "," & rs.Fields(37).Name & "," & rs.Fields(38).Name & "," & rs.Fields(39).Name & "," & rs.Fields(40).Name & "," & rs.Fields(41).Name & "," & rs.Fields(42).Name & "," & rs.Fields(43).Name & "," & rs.Fields(44).Name & "," & rs.Fields(45).Name & "," & rs.Fields(46).Name & "," & rs.Fields(47).Name & "," & rs.Fields(48).Name & "," & rs.Fields(49).Name & "," & rs.Fields(50).Name
75
76 'Store the values of the query in an array...
77 ReDim Preserve strRecords(i)
78
79 'strRecords(i) = rst.Fields(0) 'for 1 field
80 strRecords(i) = rs.Fields(0) & "," & rs.Fields(1) & "," & rs.Fields(2) & "," & rs.Fields(3) & "," & rs.Fields(4) & "," & rs.Fields(5) & "," & rs.Fields(6) & "," & rs.Fields(7) & "," & rs.Fields(8) & "," & rs.Fields(9) & "," & rs.Fields(10) & "," & rs.Fields(11) & "," & rs.Fields(12) & "," & rs.Fields(13) & "," & rs.Fields(14) & "," & rs.Fields(15) & "," & rs.Fields(16) & "," & rs.Fields(17) & "," & rs.Fields(18) & "," & rs.Fields(19) & "," & rs.Fields(20) & "," & rs.Fields(21) & "," & rs.Fields(22) & "," & rs.Fields(23) & "," & rs.Fields(24) & "," & rs.Fields(25) & "," & rs.Fields(26) & "," _
81 & rs.Fields(27) & "," & rs.Fields(28) & "," & rs.Fields(29) & "," & rs.Fields(30) & "," & rs.Fields(31) & "," & rs.Fields(32) & "," & rs.Fields(33) & "," & rs.Fields(34) & "," & rs.Fields(35) & "," & rs.Fields(36) & "," & rs.Fields(37) & "," & rs.Fields(38) & "," & rs.Fields(39) & "," & rs.Fields(40) & "," & rs.Fields(41) & "," & rs.Fields(42) & "," & rs.Fields(43) & "," & rs.Fields(44) & "," & "" & "," & rs.Fields(46) & "," & rs.Fields(47) & "," & rs.Fields(48) & "," & rs.Fields(49) & "," & rs.Fields(50)
82
83 'Debug.Print strRecords(i)
84
85 i = i + 1
86 rs.MoveNext
87 ReDim Preserve strRecords(i)
88 strRecords(i) = rs.Fields(0) & "," & rs.Fields(1) & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," _
89 & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & "" & "," & rs.Fields(44) & "," & rs.Fields(46) & "," & "" & "," & "" & "," & "" & "," & ""
90 End If
91
92
93 tablename = "abcd" & StrID
94 intStatus = CreateTable(strFields, strRecords(), intNumFields, tablename)
95
96
97 If intStatus = True Then
98
99 'MsgBox "テーブルが正常に作成されました。", vbOKOnly
100 DoCmd.RunSQL "INSERT INTO T_国民年金第３号住所変更届temp2 SELECT * FROM " & tablename & ";"
101 DoCmd.SetWarnings False
102 DoCmd.SetWarnings False
103 DoCmd.DeleteObject acTable, tablename
104
105 End If
106 rst.MoveNext
107
108 rs.Close
109 Set rs = Nothing
110 Loop
111 rst.Close
112 Set rst = Nothing
113 DoCmd.RunSQL "SELECT X.事業所NO, X.個人コード, max(X.住所変更対象) AS 住所変更対象, max(X.事務センター長所長) AS 事務センター長所長, max(X.副事務センター長副所長) AS 副事務センター長副所長, max(X.[グループ長課長]) AS グループ長課長, max(X.担当者) AS 担当者, max(X.提出日) AS 提出日," & _
114 "max(X.被保険者変更後住所コード) AS 被保険者変更後住所コード, max(X.配偶者変更後住所コード) AS 配偶者変更後住所コード, max(X.氏名等) AS 氏名等, max(X.事業所整理記号1) AS 事業所整理記号1, max(X.事業所整理記号2) AS 事業所整理記号2, max(X.被保険者整理番号) AS 被保険者整理番号, max(X.被保険者基礎年金番号) AS 被保険者基礎年金番号, " & _
115 "max(X.被保険者氏漢字) AS 被保険者氏漢字, max(X.被保険者名漢字) AS 被保険者名漢字, max(X.被保険者氏フリガナ) AS 被保険者氏フリガナ, max(X.被保険者名フリガナ) AS 被保険者名フリガナ, max(X.被保険者の年号) AS 被保険者の年号, max(X.被保険者の生年月日) AS 被保険者の生年月日, max(X.被保険者変更後〒) AS 被保険者変更後〒, max(X.被保険者の住所後フリガナ) AS 被保険者の住所後フリガナ, " & _
116 "max(X.被保険者の住所後) AS 被保険者の住所後, max(X.被保険者の住所前) AS 被保険者の住所前, max(X.被保険者の変更年月日) AS 被保険者の変更年月日, max(X.被保険者備考短期在留) AS 被保険者備考短期在留, max(X.被保険者備考住民票住所以外の居所) AS 被保険者備考住民票住所以外の居所, max(X.被保険者備考海外居住) AS 被保険者備考海外居住, max(X.被保険者備考その他) AS 被保険者備考その他, max(X.被保険者の事業所ＴＥＬ) AS 被保険者の事業所ＴＥＬ, " & _
117 "max(X.被保険者の事業所等在地) AS 被保険者の事業所等在地, max(X.被保険者の事業所等名称) AS 被保険者の事業所等名称, max(X.被保険者の事業主等氏名) AS 被保険者の事業主等氏名, max(X.配偶者姓漢字) AS 配偶者姓漢字, max(X.配偶者名漢字) AS 配偶者名漢字, max(X.配偶者姓ｶﾅ) AS 配偶者姓ｶﾅ, max(X.配偶者名ｶﾅ) AS 配偶者名ｶﾅ, max(X.配偶者の年号) AS 配偶者の年号, max(X.配偶者の生年月日) AS 配偶者の生年月日, max(X.配偶者の基礎年金番号) AS 配偶者の基礎年金番号, max(X.被保険者と配偶者が同居有無) AS 被保険者と配偶者が同居有無, " & _
118 "max(X.配偶者変更後〒) AS 配偶者変更後〒, max(X.配偶者変更後住所) AS 配偶者変更後住所, max(X.配偶者変更後住所ｶﾅ) AS 配偶者変更後住所ｶﾅ, max(X.配偶者変更前住所) AS 配偶者変更前住所, max(X.配偶者住所変更年月日) AS 配偶者住所変更年月日, max(X.配偶者備考短期在留) AS 配偶者備考短期在留, max(X.配偶者備考住民票住所以外の居所) AS 配偶者備考住民票住所以外の居所, max(X.配偶者備考海外居住) AS 配偶者備考海外居住, max(X.配偶者備考その他) AS 配偶者備考その他 into T_国民年金第３号住所変更届 FROM T_国民年金第３号住所変更届temp2 AS X GROUP BY X.事業所NO, X.個人コード;"
119
120 DoCmd.SetWarnings False
121 DoCmd.RunSQL "delete * from T_国民年金第３号住所変更届temp2;"
122 DoCmd.SetWarnings False
123 MsgBox "完了しました。", vbOKOnly, "完了!"
124End Sub
125
126
127Public Function CreateTable(table_fields As String, table_data As Variant, num_fields As Integer, table_name As String) As Boolean
128 Dim strCreateTable As String
129
130 Dim intCount As Integer
131
132 Dim strFields() As String
133 Dim strValues() As String
134
135 Dim strInsertSQL As String
136
137 Dim intCounter As Integer
138 Dim intData As Integer
139
140 On Error GoTo errHandler
141
142 'split the string on the comma delimiter
143 strFields = Split(table_fields, ",")
144
145 If TableExists(table_name) Then
146 'DROP THE TABLE IF IT EXISTS.
147 CurrentDb.Execute "DROP TABLE " & table_name
148 End If
149
150 'this creates the table structure...
151 strCreateTable = "CREATE TABLE " & table_name & "("
152
153 For intCounter = 0 To num_fields - 1
154 strCreateTable = strCreateTable & "[" & strFields(intCounter) & "] varchar(150),"
155 Next
156
157 If Right(strCreateTable, 1) = "," Then
158 strCreateTable = Left(strCreateTable, Len(strCreateTable) - 1)
159 strCreateTable = strCreateTable & ")"
160 End If
161
162 CurrentDb.Execute strCreateTable
163
164 intCounter = 0 'reset
165 intData = 0 'reset
166
167 If Err.Number = 0 Then
168
169 For intData = 0 To UBound(table_data)
170
171 'split the row on the comma delimiter
172 strValues = Split(table_data(intData), ",")
173
174 '=======================================================================
175 'now insert the values into the new table
176 '=======================================================================
177 strInsertSQL = "INSERT INTO " & table_name & "("
178
179 For intCounter = 0 To num_fields - 1
180 strInsertSQL = strInsertSQL & "[" & strFields(intCounter) & "],"
181 Next
182
183 If Right(strInsertSQL, 1) = "," Then
184 strInsertSQL = Left(strInsertSQL, Len(strInsertSQL) - 1)
185 strInsertSQL = strInsertSQL & ")"
186 End If
187
188 '==================================================
189 'now enter the values...
190 '==================================================
191 strInsertSQL = strInsertSQL & " VALUES ("
192
193 intCounter = 0
194
195 For intCounter = 0 To num_fields - 1
196 strInsertSQL = strInsertSQL & """" & strValues(intCounter) & ""","
197
198 Next
199
200 If Right(strInsertSQL, 1) = "," Then
201 strInsertSQL = Left(strInsertSQL, Len(strInsertSQL) - 1)
202 strInsertSQL = strInsertSQL & ")"
203 End If
204
205 '==================================================
206 'insert data row... '==================================================
207 Debug.Print strInsertSQL
208 CurrentDb.Execute strInsertSQL
209
210 Next 'next data row
211
212 CreateTable = True
213 End If
214
215 Exit Function
216errHandler:
217 CreateTable = False
218 MsgBox Err.Number & " " & Err.Description
219
220End Function
221
222Public Function DropTable(strTableName) As Boolean
223 Dim db As Object
224 Dim td As Object
225
226 Set db = CreateObject("DAO.DBEngine.36")
227 Set db = CurrentDb
228
229 'Find the table
230 Set td = db.TableDefs(strTableName)
231
232 'Drop the table
233 CurrentProject.Connection.Execute "DROP TABLE [" & strTableName & "]"
234
235 Set td = Nothing
236 Set db = Nothing
237
238 DropTable = True
239
240End Function
241
242Public Function TableExists(strTable As String) As Boolean
243 Dim rst As Recordset
244 Dim strSQL As String
245
246 On Error GoTo errHandler
247
248 'FOR SQL Server
249 'strsql = "SELECT name FROM Msysobjects WHERE type='u' AND Name='Transformers'" for projects
250
251 'FOR Access
252 strSQL = "SELECT MSysObjects.Name FROM MSysObjects WHERE MSysObjects.Name='" & strTable & "'"
253
254 Set rst = CurrentDb.OpenRecordset(strSQL)
255
256 If Not rst.EOF Then
257 TableExists = True
258 Else
259 TableExists = False
260 End If
261
262 rst.Close
263 Set rst = Nothing
264
265 Exit Function
266
267errHandler:
268 TableExists = False
269 MsgBox Err.Number & " " & Err.Description
270
271End Function