質問編集履歴
8
修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -169,7 +169,6 @@
|
|
|
169
169
|
|
|
170
170
|
|
|
171
171
|
[現状の実行結果]
|
|
172
|
-
|
|
173
|
-
|
|
174
173
|
[実装したい実行結果]
|
|
175
174
|
|
7
ソースの追加
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -11,119 +11,157 @@
|
|
|
11
11
|
C列が2でセル結合しているとき.MergeCellsがTrueの時に.MergeArea.Count = 2のとき
|
|
12
12
|
C列に文字列が入っているとき、[担当者][工数]の値をコピー先の行へ設定する。
|
|
13
13
|
|
|
14
|
-
---
|
|
14
|
+
---
|
|
15
15
|
|
|
16
16
|
[現状のソース]
|
|
17
17
|
```Macro
|
|
18
|
-
|
|
18
|
+
Sub sample1()
|
|
19
|
-
'-------------------------------------------------------------------------------
|
|
20
|
-
' sample1
|
|
21
|
-
' 説明
|
|
22
|
-
' コピー元のEcxelシート内[更新]シートから内容をコピーする
|
|
23
|
-
' パラメータ
|
|
24
|
-
' なし
|
|
25
|
-
' 戻り値
|
|
26
|
-
' なし
|
|
27
|
-
'-------------------------------------------------------------------------------
|
|
28
19
|
|
|
20
|
+
Dim lngRowsNo As Long ' 書きこむ位置(行)
|
|
21
|
+
Dim lngSheetIndex As Long ' シートの番号
|
|
29
|
-
Dim
|
|
22
|
+
Dim strFile As String ' Excelファイルの場所
|
|
30
|
-
Dim
|
|
23
|
+
Dim xlsAcq As New Excel.Application ' 取得側Excel
|
|
31
|
-
Dim
|
|
24
|
+
Dim wbAcq As Workbook ' 取得側Excelブック
|
|
32
|
-
Dim
|
|
25
|
+
Dim wsAcq As Worksheet ' 取得側Excelシート
|
|
33
|
-
Dim lngFromSheetNo As Long ' 検索するシートの番号
|
|
34
|
-
Dim
|
|
26
|
+
Dim wsSet As Worksheet ' 設定側Excelシート
|
|
27
|
+
Const strPath As String = "/Users/keiichi/Desktop/マクロ宿題/"
|
|
28
|
+
Set wsSet = ActiveSheet
|
|
29
|
+
Dim i As Long
|
|
35
30
|
|
|
36
|
-
|
|
31
|
+
strFile = Dir(strPath & "*.xls")
|
|
37
|
-
|
|
32
|
+
lngRowsNo = 3 ' 書きこみ開始位置(行)
|
|
33
|
+
Do Until strFile = ""
|
|
34
|
+
'----- Excelブックを開く
|
|
38
|
-
|
|
35
|
+
Set wbAcq = Workbooks.Open(strPath & strFile)
|
|
39
36
|
|
|
37
|
+
'----- シートを検索
|
|
38
|
+
For lngSheetIndex = 1 To wbAcq.Worksheets.Count
|
|
39
|
+
'----- 「更新」シートを検索
|
|
40
|
+
If wbAcq.Worksheets(lngSheetIndex).Name = "最新" Then
|
|
41
|
+
'----- 「更新」シートを変数へ登録
|
|
42
|
+
|
|
43
|
+
Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
|
|
44
|
+
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
|
|
45
|
+
With wsAcq
|
|
46
|
+
Dim fname As String 'ファイル名
|
|
47
|
+
Dim n As Long 'ループで使用します。
|
|
48
|
+
Dim m As Long 'ループで使用します。
|
|
49
|
+
Dim ec1 As Long '各開発の一番下の担当者のセルを取得
|
|
40
|
-
|
|
50
|
+
Dim ec2 As Long '各開発の 月の一番右（最後）のセルを取得
|
|
51
|
+
Dim ec3 As Long '月数を取得
|
|
52
|
+
Dim ColumnNo As Long ' 転記先の列番号（初期値４）
|
|
53
|
+
Dim ColumnNo2 As Long ' 転記元の列番号（初期値５）＋３されていく
|
|
54
|
+
|
|
55
|
+
ColumnNo = 4
|
|
56
|
+
ColumnNo2 = 5
|
|
41
57
|
|
|
42
|
-
|
|
58
|
+
For i = 1 To .UsedRange.Rows.Count
|
|
43
59
|
|
|
60
|
+
If (Left(.Cells(i, 2).Value, 2) = "A1" Or Left(.Cells(i, 2).Value, 2) = "B1" Or Left(.Cells(i, 2).Value, 2) = "C1") And .Cells(i, 2).MergeCells = False Then
|
|
61
|
+
|
|
62
|
+
'月を取得して転記
|
|
63
|
+
ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
|
|
64
|
+
|
|
65
|
+
For col = 5 To ec2
|
|
66
|
+
|
|
44
|
-
|
|
67
|
+
'「担当者」の転記
|
|
45
|
-
|
|
68
|
+
wsSet.Cells(lngRowsNo - 1, 3).Value = .Cells(i + 1, 3).Value
|
|
69
|
+
|
|
46
|
-
|
|
70
|
+
'「担当者」以降の 「月」の転記
|
|
71
|
+
wsSet.Cells(lngRowsNo - 1, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
|
|
72
|
+
|
|
73
|
+
ColumnNo = ColumnNo + 1
|
|
47
|
-
|
|
74
|
+
ColumnNo2 = ColumnNo2 + 3
|
|
48
75
|
|
|
76
|
+
Next col
|
|
77
|
+
|
|
49
|
-
|
|
78
|
+
' ------ 開発〇から一番上の担当者のセル位置を相対的にCells(i + 3, 3)として取得し
|
|
50
|
-
strFromXMLFileName = Dir(strDefaultPath & "*.xls")
|
|
51
|
-
|
|
52
|
-
' Excelファイルが見つからなくなるまで検索
|
|
53
|
-
Do Until strFromXMLFileName = ""
|
|
54
|
-
|
|
55
|
-
' 見つかったExcelブックを開く
|
|
56
|
-
Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
|
|
57
|
-
|
|
58
|
-
|
|
79
|
+
'データの入っているところまでループさせる (その時、開発名を転記)
|
|
59
|
-
|
|
80
|
+
ec1 = .Cells(i + 3, 2).End(xlDown).Row
|
|
60
|
-
|
|
61
|
-
|
|
81
|
+
For n = i + 3 To ec1
|
|
62
|
-
|
|
82
|
+
|
|
63
|
-
|
|
64
|
-
|
|
83
|
+
'担当者が空白の時スキップする
|
|
65
|
-
Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
|
|
66
|
-
|
|
67
|
-
' 2. コピー元のシートを1行目から検索(登録がある行すべて)
|
|
68
|
-
For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
|
|
69
|
-
|
|
70
|
-
' C列=3 が結合セルの場合
|
|
71
|
-
If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
|
|
72
|
-
Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
|
|
73
|
-
Case 4
|
|
74
|
-
' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
|
|
75
|
-
|
|
84
|
+
If Cells(n, 3) = "" Then
|
|
76
|
-
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
|
|
77
|
-
wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
|
|
78
|
-
' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
|
|
79
|
-
|
|
85
|
+
GoTo NEXT99
|
|
80
|
-
|
|
86
|
+
End If
|
|
81
|
-
|
|
87
|
+
|
|
82
|
-
|
|
88
|
+
'ファイル名
|
|
83
|
-
' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
|
|
84
|
-
If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
|
|
85
|
-
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
|
|
86
|
-
|
|
87
|
-
' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
|
|
88
|
-
|
|
89
|
+
fname = ActiveWorkbook.Name
|
|
90
|
+
wsSet.Cells(lngRowsNo, 1).Value = fname
|
|
91
|
+
If .MergeArea.Count = 4 Then
|
|
89
|
-
|
|
92
|
+
End If
|
|
93
|
+
'メソッドまたはデータメンバーが見つかりません
|
|
90
|
-
|
|
94
|
+
'開発
|
|
91
|
-
Else
|
|
92
|
-
Select Case Left(wsFrom.Cells(lngFromRowsNo, 2).Value, 2) 'B列=2 左から2文字を取得
|
|
93
|
-
Case "A1", "A2", "A3"
|
|
94
|
-
' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
|
|
95
|
-
|
|
95
|
+
wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
|
|
96
|
+
|
|
97
|
+
'担当者
|
|
98
|
+
wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
|
|
99
|
+
|
|
100
|
+
'工数
|
|
101
|
+
wsSet.Cells(lngRowsNo, 4).Value = .Cells(n, 5).Value
|
|
102
|
+
|
|
103
|
+
wsSet.Cells(lngRowsNo, 5).Value = .Cells(n, 8).Value
|
|
104
|
+
|
|
105
|
+
wsSet.Cells(lngRowsNo, 6).Value = .Cells(n, 11).Value
|
|
106
|
+
|
|
107
|
+
wsSet.Cells(lngRowsNo, 7).Value = .Cells(n, 14).Value
|
|
108
|
+
|
|
109
|
+
wsSet.Cells(lngRowsNo, 8).Value = .Cells(n, 17).Value
|
|
110
|
+
|
|
111
|
+
wsSet.Cells(lngRowsNo, 9).Value = .Cells(n, 20).Value
|
|
112
|
+
|
|
113
|
+
wsSet.Cells(lngRowsNo, 10).Value = .Cells(n, 23).Value
|
|
114
|
+
|
|
115
|
+
wsSet.Cells(lngRowsNo, 11).Value = .Cells(n, 26).Value
|
|
116
|
+
|
|
117
|
+
wsSet.Cells(lngRowsNo, 12).Value = .Cells(n, 29).Value
|
|
118
|
+
|
|
119
|
+
wsSet.Cells(lngRowsNo, 13).Value = .Cells(n, 32).Value
|
|
120
|
+
|
|
96
|
-
|
|
121
|
+
'１行下へ
|
|
122
|
+
lngRowsNo = lngRowsNo + 1
|
|
123
|
+
|
|
124
|
+
NEXT99:
|
|
125
|
+
Next n
|
|
126
|
+
|
|
97
127
|
End If
|
|
98
|
-
|
|
128
|
+
Next i
|
|
129
|
+
End With
|
|
130
|
+
|
|
99
|
-
|
|
131
|
+
'----- 検索の終了
|
|
100
|
-
|
|
101
|
-
' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
|
|
102
132
|
Exit For
|
|
103
|
-
|
|
104
133
|
End If
|
|
134
|
+
Next lngSheetIndex
|
|
105
135
|
|
|
136
|
+
'----- シート参照の解放
|
|
106
|
-
|
|
137
|
+
Set wsAcq = Nothing
|
|
107
|
-
|
|
108
|
-
'
|
|
138
|
+
'----- ブックを閉じる
|
|
109
|
-
|
|
139
|
+
wbAcq.Close Savechanges:=False
|
|
110
|
-
|
|
140
|
+
|
|
111
|
-
|
|
112
|
-
' 次の
|
|
141
|
+
'----- 次のファイルへ
|
|
113
|
-
|
|
142
|
+
strFile = Dir()
|
|
143
|
+
|
|
144
|
+
|
|
114
145
|
Loop
|
|
115
146
|
|
|
147
|
+
'----- Excelへの参照の解放
|
|
116
|
-
|
|
148
|
+
Set xlsAcq = Nothing
|
|
149
|
+
|
|
150
|
+
Dim maxrow As Long '最終行
|
|
151
|
+
maxrow = wsSet.Cells(Rows.Count, 3).End(xlUp).Row 'C列で最終行を求める
|
|
117
|
-
|
|
152
|
+
For i = 3 To maxrow
|
|
153
|
+
|
|
154
|
+
If wsSet.Cells(i, "C").Value = "担当者" Then
|
|
155
|
+
wsSet.Cells(i, "A").Value = ""
|
|
156
|
+
wsSet.Cells(i, "B").Value = ""
|
|
118
|
-
|
|
157
|
+
End If
|
|
158
|
+
Next
|
|
119
159
|
|
|
120
|
-
'----- エラー処理
|
|
121
|
-
sample1_Error:
|
|
122
|
-
Resume sample1_End:
|
|
123
160
|
End Sub
|
|
124
161
|
|
|
125
162
|
```
|
|
126
163
|
|
|
164
|
+
|
|
127
165
|
質問２.xls
|
|
128
166
|
|
|
129
167
|
|
6
ソースの修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -37,7 +37,7 @@
|
|
|
37
37
|
Dim lngToRowsNo As Long ' 書きこむ行位置
|
|
38
38
|
Dim varKaihatsu As Variant ' [開発]の値
|
|
39
39
|
|
|
40
|
-
Const strDefaultPath As String = "
|
|
40
|
+
Const strDefaultPath As String = "指定パス" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
|
|
41
41
|
|
|
42
42
|
On Error GoTo sample1_Error:
|
|
43
43
|
|
|
@@ -59,7 +59,7 @@
|
|
|
59
59
|
For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
|
|
60
60
|
|
|
61
61
|
' シート名が"更新"のシートを検索
|
|
62
|
-
If wbFrom.Worksheets(lngFromSheetNo).Name = "
|
|
62
|
+
If wbFrom.Worksheets(lngFromSheetNo).Name = "更新" Then
|
|
63
63
|
|
|
64
64
|
' コピー元のシートを設定
|
|
65
65
|
Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
|
5
文言の修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -13,16 +13,6 @@
|
|
|
13
13
|
|
|
14
14
|
----
|
|
15
15
|
|
|
16
|
-
[補足]
|
|
17
|
-
上記の実装をする際に以下のコードをコンパイルしてみたら
|
|
18
|
-
'メソッドまたはデータメンバーが見つかりません
|
|
19
|
-
というエラーが出てしまいました。。
|
|
20
|
-
```Macro
|
|
21
|
-
'メソッドまたはデータメンバーが見つかりません
|
|
22
|
-
If .MergeArea.Count = 4 Then
|
|
23
|
-
End If
|
|
24
|
-
```
|
|
25
|
-
|
|
26
16
|
[現状のソース]
|
|
27
17
|
```Macro
|
|
28
18
|
Public Sub sample1()
|
4
ソースの修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -84,7 +84,7 @@
|
|
|
84
84
|
' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
|
|
85
85
|
If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
|
|
86
86
|
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
|
|
87
|
-
wsTo.Cells(
|
|
87
|
+
wsTo.Cells(lngToRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
|
|
88
88
|
' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
|
|
89
89
|
lngToRowsNo = lngToRowsNo + 1
|
|
90
90
|
End If
|
|
@@ -141,7 +141,7 @@
|
|
|
141
141
|
|
|
142
142
|
|
|
143
143
|
[現状の実行結果]
|
|
144
|
-
|
|
145
145
|
|
|
146
146
|
[実装したい実行結果]
|
|
147
147
|
|
3
ソースの修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -47,7 +47,7 @@
|
|
|
47
47
|
Dim lngToRowsNo As Long ' 書きこむ行位置
|
|
48
48
|
Dim varKaihatsu As Variant ' [開発]の値
|
|
49
49
|
|
|
50
|
-
Const strDefaultPath As String = "
|
|
50
|
+
Const strDefaultPath As String = "/Users/keiichi/Desktop/マクロ宿題/" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
|
|
51
51
|
|
|
52
52
|
On Error GoTo sample1_Error:
|
|
53
53
|
|
|
@@ -69,7 +69,7 @@
|
|
|
69
69
|
For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
|
|
70
70
|
|
|
71
71
|
' シート名が"更新"のシートを検索
|
|
72
|
-
If wbFrom.Worksheets(lngFromSheetNo).Name = "
|
|
72
|
+
If wbFrom.Worksheets(lngFromSheetNo).Name = "最新" Then
|
|
73
73
|
|
|
74
74
|
' コピー元のシートを設定
|
|
75
75
|
Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
|
|
@@ -84,7 +84,7 @@
|
|
|
84
84
|
' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
|
|
85
85
|
If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
|
|
86
86
|
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
|
|
87
|
-
|
|
87
|
+
wsTo.Cells(lngRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
|
|
88
88
|
' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
|
|
89
89
|
lngToRowsNo = lngToRowsNo + 1
|
|
90
90
|
End If
|
|
@@ -132,7 +132,6 @@
|
|
|
132
132
|
Resume sample1_End:
|
|
133
133
|
End Sub
|
|
134
134
|
|
|
135
|
-
|
|
136
135
|
```
|
|
137
136
|
|
|
138
137
|
質問２.xls
|
2
ソース修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -25,151 +25,114 @@
|
|
|
25
25
|
|
|
26
26
|
[現状のソース]
|
|
27
27
|
```Macro
|
|
28
|
-
Sub sample1()
|
|
28
|
+
Public Sub sample1()
|
|
29
|
+
'-------------------------------------------------------------------------------
|
|
30
|
+
' sample1
|
|
31
|
+
' 説明
|
|
32
|
+
' コピー元のEcxelシート内[更新]シートから内容をコピーする
|
|
33
|
+
' パラメータ
|
|
34
|
+
' なし
|
|
35
|
+
' 戻り値
|
|
36
|
+
' なし
|
|
37
|
+
'-------------------------------------------------------------------------------
|
|
29
38
|
|
|
30
|
-
Dim lngRowsNo As Long ' 書きこむ位置(行)
|
|
31
|
-
Dim lngSheetIndex As Long ' シートの番号
|
|
32
|
-
Dim
|
|
39
|
+
Dim strFromXMLFileName As String ' コピー元となるExcelファイルの名前
|
|
33
|
-
Dim
|
|
40
|
+
Dim xlsFrom As New Excel.Application ' 取得側Excel
|
|
34
|
-
Dim
|
|
41
|
+
Dim wbFrom As Workbook ' 取得側Excelブック
|
|
35
|
-
Dim
|
|
42
|
+
Dim wsFrom As Worksheet ' 取得側Excelシート
|
|
43
|
+
Dim lngFromSheetNo As Long ' 検索するシートの番号
|
|
36
|
-
Dim
|
|
44
|
+
Dim lngFromRowsNo As Long ' 検索する行位置
|
|
37
|
-
Const strPath As String = "パスを指定する"
|
|
38
|
-
Set wsSet = ActiveSheet
|
|
39
|
-
Dim i As Long
|
|
40
45
|
|
|
41
|
-
|
|
46
|
+
Dim wsTo As Worksheet ' 設定側Excelシート
|
|
42
|
-
|
|
47
|
+
Dim lngToRowsNo As Long ' 書きこむ行位置
|
|
43
|
-
Do Until strFile = ""
|
|
44
|
-
'----- Excelブックを開く
|
|
45
|
-
|
|
48
|
+
Dim varKaihatsu As Variant ' [開発]の値
|
|
46
49
|
|
|
47
|
-
'----- シートを検索
|
|
48
|
-
For lngSheetIndex = 1 To wbAcq.Worksheets.Count
|
|
49
|
-
'----- 「更新」シートを検索
|
|
50
|
-
If wbAcq.Worksheets(lngSheetIndex).Name = "更新" Then
|
|
51
|
-
'----- 「更新」シートを変数へ登録
|
|
52
|
-
|
|
53
|
-
Set wsAcq = wbAcq.Worksheets(lngSheetIndex)
|
|
54
|
-
'----- 「更新」シートの内容を現在のシートにコピー(自由に変更して下さい)
|
|
55
|
-
With wsAcq
|
|
56
|
-
Dim fname As String 'ファイル名
|
|
57
|
-
Dim n As Long 'ループで使用します。
|
|
58
|
-
Dim m As Long 'ループで使用します。
|
|
59
|
-
Dim ec1 As Long '各開発の一番下の担当者のセルを取得
|
|
60
|
-
|
|
50
|
+
Const strDefaultPath As String = "パス指定" 'コピー元となるExcelファイルが置いてあるフォルダのパス(\で終わる事)
|
|
61
|
-
Dim ec3 As Long '月数を取得
|
|
62
|
-
Dim ColumnNo As Long ' 転記先の列番号（初期値４）
|
|
63
|
-
Dim ColumnNo2 As Long ' 転記元の列番号（初期値５）＋３されていく
|
|
64
|
-
|
|
65
|
-
ColumnNo = 4
|
|
66
|
-
ColumnNo2 = 5
|
|
67
51
|
|
|
68
|
-
|
|
52
|
+
On Error GoTo sample1_Error:
|
|
69
53
|
|
|
70
|
-
If (Left(.Cells(i, 2).Value, 2) = "A1" Or Left(.Cells(i, 2).Value, 2) = "B1" Or Left(.Cells(i, 2).Value, 2) = "C1") And .Cells(i, 2).MergeCells = False Then
|
|
71
|
-
|
|
72
|
-
'月を取得して転記
|
|
73
|
-
ec2 = .Cells(i + 1, 5).End(xlToRight).Column + 1
|
|
74
|
-
|
|
75
|
-
For col = 5 To ec2
|
|
76
|
-
|
|
77
|
-
|
|
54
|
+
' コピー先の設定
|
|
78
|
-
|
|
55
|
+
Set wsTo = ActiveSheet ' 書きこむシートは今開いているシート
|
|
79
|
-
|
|
80
|
-
|
|
56
|
+
' 1. コピー先の開始行は2行目から開始とする。
|
|
81
|
-
wsSet.Cells(lngRowsNo - 1, ColumnNo).Value = .Cells(i + 1, ColumnNo2).Value
|
|
82
|
-
|
|
83
|
-
ColumnNo = ColumnNo + 1
|
|
84
|
-
|
|
57
|
+
lngToRowsNo = 2 ' 書きこむ行位置2行目から
|
|
85
58
|
|
|
86
|
-
Next col
|
|
87
|
-
|
|
88
|
-
|
|
59
|
+
' コピー元となるExcelファイルが置いてあるフォルダのパスからExcelファイルを検索する
|
|
89
|
-
'データの入っているところまでループさせる (その時、開発名を転記)
|
|
90
|
-
ec1 = .Cells(i + 3, 2).End(xlDown).Row
|
|
91
|
-
For n = i + 3 To ec1
|
|
92
|
-
|
|
93
|
-
'担当者が空白の時スキップする
|
|
94
|
-
If Cells(n, 3) = "" Then
|
|
95
|
-
GoTo NEXT99
|
|
96
|
-
End If
|
|
97
|
-
|
|
98
|
-
'ファイル名
|
|
99
|
-
fname = ActiveWorkbook.Name
|
|
100
|
-
wsSet.Cells(lngRowsNo, 1).Value = fname
|
|
101
|
-
|
|
102
|
-
'開発
|
|
103
|
-
|
|
60
|
+
strFromXMLFileName = Dir(strDefaultPath & "*.xls")
|
|
104
|
-
|
|
105
|
-
'担当者
|
|
106
|
-
If .MergeArea.Count = 4 Then
|
|
107
|
-
End If
|
|
108
|
-
wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
|
|
109
61
|
|
|
110
|
-
|
|
62
|
+
' Excelファイルが見つからなくなるまで検索
|
|
63
|
+
Do Until strFromXMLFileName = ""
|
|
64
|
+
|
|
65
|
+
' 見つかったExcelブックを開く
|
|
66
|
+
Set wbFrom = Workbooks.Open(strDefaultPath & strFromXMLFileName)
|
|
67
|
+
|
|
68
|
+
' 見つかったExcelブックのシートを順番に検索(登録があるシートすべて)
|
|
69
|
+
For lngFromSheetNo = 1 To wbFrom.Worksheets.Count
|
|
70
|
+
|
|
71
|
+
' シート名が"更新"のシートを検索
|
|
72
|
+
If wbFrom.Worksheets(lngFromSheetNo).Name = "更新" Then
|
|
73
|
+
|
|
111
|
-
|
|
74
|
+
' コピー元のシートを設定
|
|
75
|
+
Set wsFrom = wbFrom.Worksheets(lngFromSheetNo)
|
|
76
|
+
|
|
77
|
+
' 2. コピー元のシートを1行目から検索(登録がある行すべて)
|
|
78
|
+
For lngFromRowsNo = 1 To wsFrom.UsedRange.Rows.Count
|
|
79
|
+
|
|
80
|
+
' C列=3 が結合セルの場合
|
|
112
|
-
|
|
81
|
+
If wsFrom.Cells(lngFromRowsNo, 3).MergeCells = True Then
|
|
113
|
-
|
|
114
|
-
|
|
82
|
+
Select Case wsFrom.Cells(lngFromRowsNo, 3).MergeArea.Count
|
|
115
|
-
|
|
83
|
+
Case 4
|
|
84
|
+
' 4. C列が4セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 4 の場合)
|
|
116
|
-
|
|
85
|
+
If wsFrom.Cells(lngFromRowsNo, 3).Value = "担当者" Then
|
|
117
|
-
|
|
118
|
-
wsSet.Cells(lngRowsNo, 7).Value = .Cells(n, 14).Value
|
|
119
|
-
|
|
120
|
-
wsSet.Cells(lngRowsNo, 8).Value = .Cells(n, 17).Value
|
|
121
|
-
|
|
122
|
-
wsSet.Cells(lngRowsNo, 9).Value = .Cells(n, 20).Value
|
|
123
|
-
|
|
124
|
-
|
|
86
|
+
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
|
|
125
|
-
|
|
126
|
-
wsSet.Cells(lngRowsNo, 11).Value = .Cells(n, 26).Value
|
|
127
|
-
|
|
128
|
-
wsSet.Cells(lngRowsNo, 12).Value = .Cells(n, 29).Value
|
|
129
|
-
|
|
130
|
-
|
|
87
|
+
wsSet.Cells(lngRowsNo, 3).Value = wsFrom.Cells(lngFromRowsNo, 3).Value
|
|
131
|
-
|
|
132
|
-
|
|
88
|
+
' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
|
|
133
|
-
|
|
89
|
+
lngToRowsNo = lngToRowsNo + 1
|
|
134
|
-
|
|
135
|
-
|
|
90
|
+
End If
|
|
91
|
+
|
|
136
|
-
|
|
92
|
+
Case 2
|
|
137
|
-
|
|
93
|
+
' 5. C列が2セル結合している場合(.MergeCellsがTrueの時に.MergeArea.Count = 2 の場合)
|
|
94
|
+
If IsNull(wsFrom.Cells(lngFromRowsNo, 3).Value) = False And wsFrom.Cells(lngFromRowsNo, 3).Value <> "" Then
|
|
95
|
+
' 4.1. C列に"担当者"という文字列が入っている場合、表のヘッダーとして[年月]の値をコピー先の行へ設定する。
|
|
96
|
+
|
|
97
|
+
' ※コピー先の行へ設定した場合追加なので､コピー先は次の行へ移動
|
|
98
|
+
lngToRowsNo = lngToRowsNo + 1
|
|
99
|
+
End If
|
|
100
|
+
End Select
|
|
101
|
+
Else
|
|
102
|
+
Select Case Left(wsFrom.Cells(lngFromRowsNo, 2).Value, 2) 'B列=2 左から2文字を取得
|
|
103
|
+
Case "A1", "A2", "A3"
|
|
104
|
+
' 3. B列に"A1"or"B1"or"C1"で始まる文字列がある場合、[開発]の値として変数に代入しておく。
|
|
105
|
+
varKaihatsu = wsFrom.Cells(lngFromRowsNo, 2).Value ' [開発]の値
|
|
106
|
+
End Select
|
|
138
107
|
End If
|
|
139
|
-
|
|
108
|
+
|
|
140
|
-
End With
|
|
141
|
-
|
|
142
|
-
|
|
109
|
+
Next lngFromRowsNo
|
|
110
|
+
|
|
111
|
+
' 1つのExcelファイルには同じ名前のシートが作成できないのでシート検索処理を終了する
|
|
143
112
|
Exit For
|
|
113
|
+
|
|
144
114
|
End If
|
|
145
|
-
Next lngSheetIndex
|
|
146
115
|
|
|
147
|
-
'----- シート参照の解放
|
|
148
|
-
|
|
116
|
+
Next lngFromSheetNo
|
|
117
|
+
|
|
149
|
-
'
|
|
118
|
+
' 見つかったExcelブックを閉じる
|
|
150
|
-
|
|
119
|
+
Call wbFrom.Close(True) 'セーブはしない
|
|
151
|
-
|
|
120
|
+
Set wbFrom = Nothing '参照の解除
|
|
121
|
+
|
|
152
|
-
'
|
|
122
|
+
' 次のExcelファイルを検索
|
|
153
|
-
|
|
123
|
+
strFromXMLFileName = Dir()
|
|
154
|
-
|
|
155
|
-
|
|
156
124
|
Loop
|
|
157
125
|
|
|
158
|
-
'----- Excelへの参照の解放
|
|
159
|
-
|
|
126
|
+
sample1_End:
|
|
160
|
-
|
|
161
|
-
Dim maxrow As Long '最終行
|
|
162
|
-
maxrow = wsSet.Cells(Rows.Count, 3).End(xlUp).Row 'C列で最終行を求める
|
|
163
|
-
|
|
127
|
+
On Error Resume Next
|
|
164
|
-
|
|
165
|
-
If wsSet.Cells(i, "C").Value = "担当者" Then
|
|
166
|
-
wsSet.Cells(i, "A").Value = ""
|
|
167
|
-
wsSet.Cells(i, "B").Value = ""
|
|
168
|
-
|
|
128
|
+
Exit Sub
|
|
169
|
-
Next
|
|
170
129
|
|
|
130
|
+
'----- エラー処理
|
|
131
|
+
sample1_Error:
|
|
132
|
+
Resume sample1_End:
|
|
171
133
|
End Sub
|
|
172
134
|
|
|
135
|
+
|
|
173
136
|
```
|
|
174
137
|
|
|
175
138
|
質問２.xls
|
1
内容の修正
title
CHANGED
|
File without changes
|
body
CHANGED
|
@@ -103,7 +103,10 @@
|
|
|
103
103
|
wsSet.Cells(lngRowsNo, 2).Value = .Cells(i, 2).Value
|
|
104
104
|
|
|
105
105
|
'担当者
|
|
106
|
+
If .MergeArea.Count = 4 Then
|
|
107
|
+
End If
|
|
106
108
|
wsSet.Cells(lngRowsNo, 3).Value = .Cells(n, 3).Value
|
|
109
|
+
|
|
107
110
|
|
|
108
111
|
'工数
|
|
109
112
|
wsSet.Cells(lngRowsNo, 4).Value = .Cells(n, 5).Value
|