回答編集履歴

1

追記をうけて

2016/08/26 04:38

投稿

jawa
jawa

スコア3013

test CHANGED
@@ -84,4 +84,122 @@
84
84
 
85
85
  ```
86
86
 
87
+
88
+
89
+ 追加で記載いただいたコードについて
90
+
91
+ ---
92
+
93
+ 今手元に動作確認できる環境がないので未確認での指摘です。すみません。
94
+
95
+
96
+
97
+ まず、`Windows("VBAテスト.xlsx").Activate`の部分について。
98
+
99
+ 最初に「ActiveWorkbookの全シート」を対象にループ処理していますが、そのループの最中に「別のブックをアクティブ化」してしまうことになります。
100
+
101
+ 動作させてみないとわかりませんが、そんなことをして最初のループが正しく継続されるかが心配です。
102
+
103
+
104
+
105
+ 次に、
106
+
107
+ `lastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row + 1`
108
+
109
+ の部分ですが、おそらく出力ブックの最終行から次の出力位置を取得したいのだと思いますが、shtは読取ブック内のシートです。
110
+
111
+
112
+
113
+ 最後に
114
+
115
+ `Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False`
116
+
117
+ の部分ですが、`Selection`は現在のアクティブシート上で選択されているセル(またはオブジェクト)を意味します。
118
+
119
+
120
+
87
- 参考まで
121
+ これ以前
122
+
123
+ `Windows("VBAテスト.xlsx").Activate`
124
+
125
+ でブックはアクティブ化していますが、出力先のシートや対象セルは指定していないので「たまたまそのブックで選択されているセルに出力する」ような動作になってしまうと思います。
126
+
127
+ せっかくlastRowを取得していますがこれも利用していません。
128
+
129
+
130
+
131
+ 貼り付け先を指定したコピー&ペーストにするか、もしくはSelectionを使うなら事前に貼り付けるセルをSelectする必要があります。
132
+
133
+
134
+
135
+ 以上をまとめると以下のようなコードになると思います。
136
+
137
+ ```
138
+
139
+ Sub 書きかけ()
140
+
141
+ Dim wbRead As Workbook
142
+
143
+ Dim wbOut As Workbook
144
+
145
+ Dim shtRead As Worksheet
146
+
147
+ Dim shtOut As Worksheet
148
+
149
+
150
+
151
+ Set wbRead = ActiveWorkbook
152
+
153
+ Set wbOut = Workbooks("4.xls")
154
+
155
+ Set shtOut = wbOut.Worksheets("Sheet1")
156
+
157
+
158
+
159
+ Dim rng As Range
160
+
161
+ Dim lastRow As Long
162
+
163
+
164
+
165
+ '現在のブック内にあるすべてのシートをループ処理
166
+
167
+ For Each shtRead In wbRead.Worksheets
168
+
169
+ '対象シート内のA列先頭からA列最終データ行までをループ処理
170
+
171
+ For Each rng In shtRead.Range(shtRead.Cells(1, 1), shtRead.Cells(shtRead.Rows.Count, 1).End(xlUp))
172
+
173
+ 'A列が1なら、その行をコピー
174
+
175
+ If shtRead.Cells(rng.Row, 1) = 1 Then
176
+
177
+ '読込シートから行コピー
178
+
179
+ shtRead.Rows(rng.Row).Copy
180
+
181
+
182
+
183
+ 'DBブックを選択し、一番下の行番号を取得
184
+
185
+ lastRow = shtOut.Cells(shtOut.Rows.Count, 1).End(xlUp).Row + 1
186
+
187
+ '出力シートに値で貼り付け
188
+
189
+ shtOut.Rows(lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
190
+
191
+ :=False, Transpose:=False
192
+
193
+ End If
194
+
195
+ Next rng
196
+
197
+ Next shtRead
198
+
199
+ End Sub
200
+
201
+ ```
202
+
203
+
204
+
205
+ 実行環境がないため、エラー等あるかもしれません。参考までに。