| |
n様、さらなるご教授ありがとうございましたm(_ _)m
>補足ですが、ActivateやSelectに頼ると状況によっては不具合の元ですし、
>実行速度にも影響してきます。
オブジェクトにしてみたところ、スピードが全然違いました！！
これは超重要事項ですね。
Activate多用は「うおーなんか自動で動いてるー」というのが見える以外、特に使うメリットは多くないんですね。
>VBEのヘルプは状況依存型で、コード内の調査語句にマウスキャレットをあてて[F1]キーを押せば
こ、これは・・・便利すぎます。大変ありがとうございます。
あとエラーチェックや実行時のデバッグも親切で、VBAを作る人の意欲が失われにくくなってると思いました。
>またLoop処理についてはFor...Nextステートメントについて調べてみてください。
使ってみました！ちょっとスッキリしました。あと、一回一回空白かどうか判定する前回の処理よりも、一度データの最終行を取得してループする方がスピードが上がりそうですね。
その他、参照するセルは各ファイルで共通なので、毎回設定を読むのではなく、最初に配列に格納してループ中はそこを見るように変えました。
（「定数式が必要です。」のエラーが多発してくじけそうになりましたが、ReDimを学びました。）
n様には大変お世話になり、改めてお礼申し上げます。
↓以下改良コード↓
-------------------
Sub 抽出実行ボタン()
' ↓対象のファイルと、抜き出すセルを設定してあり、マクロの実行ボタンがあるブック
Dim wb As Workbook
Set wb = Workbooks("PickCells.xls")
' ↓一枚目のシートが設定＆ボタン
Dim ws1 As Worksheet
Set ws1 = wb.Worksheets(1)
' ↓二枚目のシートに抽出結果を出力する
Dim ws2 As Worksheet
Set ws2 = wb.Worksheets(2)
' ↓開くブックのワーク変数
Dim wk_wb As Workbook
Dim wk_ws As Worksheet
' ↓抽出対象のファイルパスが書いてある列
Dim filePathCol As String
filePathCol = "B"
' ↓抽出対象のファイルが列挙してある最初の行
Dim counter_file As Integer
counter_file = 8
' ↓抽出対象のファイルが列挙してある最後の行
Dim mxRow_file As Integer
Dim i_file As Integer
If ws1.Range(filePathCol + CStr(counter_file + 1)).Value <> "" Then
mxRow_file = ws1.Range(filePathCol + CStr(counter_file)).End(xlDown).Row
Else
mxRow_file = counter_file
' ↑一行しかない場合End(xlDown)はシート最終行を取得してしまうので
End If
' ↓抽出対象のセルが列挙してある列
Dim cellPlaceCol As String
cellPlaceCol = "D"
' ↓抽出対象のセルのシートが列挙してある列
Dim cellSheetPlaceCol As String
cellSheetPlaceCol = "E"
' ↓抽出対象のセルが列挙してある最初の行
Dim counter_cell As Integer
counter_cell = 8
' ↓抽出対象のセルが列挙してある最後の行
Dim mxRow_cell As Integer
If ws1.Range(cellPlaceCol + CStr(counter_cell + 1)).Value <> "" Then
mxRow_cell = ws1.Range(cellPlaceCol + CStr(counter_cell)).End(xlDown).Row
Else
mxRow_cell = counter_cell
End If
' ↓ファイル数の回数繰り返し見ることになるので、予め抽出対象のセルは配列に格納してスピードアップ。
Dim cellPlaceS() As String
Dim cellSheetS() As Integer
' 変数で配列定義をしようとするとエラーになってしまうのでReDimを使う
ReDim cellPlaceS(counter_cell To mxRow_cell)
ReDim cellSheetS(counter_cell To mxRow_cell)
Dim i As Long
For i = counter_cell To mxRow_cell
cellPlaceS(i) = ws1.Range(cellPlaceCol + CStr(i)).Value
cellSheetS(i) = ws1.Range(cellSheetPlaceCol + CStr(i)).Value
' ↓シート番号は空欄だったら１にしておく
If cellSheetS(i) = 0 Then
cellSheetS(i) = 1
End If
Next i
' ↓抽出処理開始
For i_file = counter_file To mxRow_file
Dim filePath As String
filePath = ws1.Range(filePathCol + CStr(i_file)).Value
Set wk_wb = Workbooks.Open(Filename:=filePath)
Dim i_cell As Integer
For i_cell = LBound(cellPlaceS) To UBound(cellPlaceS)
Set wk_ws = wk_wb.Worksheets(cellSheetS(i_cell))
Dim targetValue As String
targetValue = wk_ws.Range(cellPlaceS(i_cell)).Value
' ↓抽出結果の見出しを作っている部分
If i_file = counter_file Then
ws2.Cells(1, i_cell - counter_cell + 1).Value = cellPlaceS(i_cell) + "(" + CStr(cellSheetS(i_cell)) + ")"
End If
' ↓ws2に抽出した内容を転記
ws2.Cells(i_file - counter_file + 2, i_cell - counter_cell + 1).Value = targetValue
Next i_cell
wk_wb.Close
Next i_file
' ↓ReDimしたら後始末が必要らしい
Erase cellPlaceS
Erase cellSheetS
' ↓おまじない
Set wb = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set wk_wb = Nothing
Set wk_ws = Nothing
End Sub
|
|
jax_6
- 08/3/30(日) 12:12 -
